;; The Right-Awful Gemini Server ;; ;; This is a gemini server in the spirit of the ;; scratchy gopher server. Just as for that server, ;; rags uses runtime evaluation of embedded scheme ;; expressions to provide dynamically generated content. ;; ;; See the readme for details. (import (chicken io) (chicken port) (chicken file) (chicken string) (chicken pathname) (chicken condition) (chicken time posix) (chicken process) (chicken process-context) (chicken process-context posix) (chicken gc) matchable srfi-13 srfi-1 uri-common tcp6 openssl) (define-record config root-dir host port certfile keyfile uid gid blacklist blacklist-resp) (define file-types '(("gmi" "text/gemini" "charset=utf-8") ("txt" "text/plain" "charset=utf-8") ("csv" "text/csv" "charset=utf-8") ("html" "text/html" "charset=utf-8") ("xml" "text/xml" "charset=utf-8") ("pdf" "application/pdf") ("zip" "application/zip") ("jpg" "image/jpeg") ("jpeg" "image/jpeg") ("png" "image/png") ("mp3" "audio/mpeg"))) (define eval-env-file "eval-env.scm") (define eval-env (interaction-environment)) (define (process-request config request-line) (let ((uri (uri-normalize-path-segments (absolute-uri request-line)))) (cond ((not (eq? (uri-scheme uri) 'gemini)) (fail-permanent "Unsupported scheme.")) ((not (uri-host uri)) (fail-permanent "URL lacks host name.")) ((not (equal? (uri-host uri) (config-host config))) (fail-permanent "Proxy requests forbidden.")) ((uri-path-relative? uri) (fail-permanent "Path must be absolute.")) ((not (document-available? config uri)) (fail-permanent "Document not found.")) ((and (document-path-directory? config uri) (uri-lacks-trailing-slash? uri)) (redirect-permanent (uri-with-trailing-slash uri))) ((document-script? config uri) (serve-script config uri)) (else (serve-document config uri))))) (define (fail-permanent reason) (print "50 " reason "\r")) (define (redirect-permanent new-uri) (print "30 " (uri->string new-uri) "\r")) (define (serve-query prompt) (print "10 " prompt "\r")) (define (uri-lacks-trailing-slash? uri) (not (string-null? (last (uri-path uri))))) (define (uri-with-trailing-slash uri) (update-uri uri path: (append (uri-path uri) '("")))) (define (document-available? config uri) (file-exists? (document-path config uri))) (define (document-script? config uri) (let ((path (document-path config uri))) (and (file-exists? path) (file-executable? path) (equal? (pathname-extension path) "scm")))) (define (document-path-directory? config uri) (directory-exists? (document-path-raw config uri))) (define (document-path-raw config uri) (let* ((crumbs (reverse (cons (config-root-dir config) (cdr (uri-path uri)))))) (make-pathname (reverse (cdr crumbs)) (car crumbs)))) (define (document-path config uri) (let* ((path (document-path-raw config uri))) (if (directory-exists? path) (make-pathname path "index.gmi") path))) (define (ext->mime ext) (let* ((mime-detected (assoc ext file-types))) (cdr (if mime-detected mime-detected (assoc "txt" file-types))))) (define (serve-document-header mime) (print "20 " (string-intersperse mime ";") "\r")) (define (serve-document config uri) (let* ((path (document-path config uri)) (ext (pathname-extension path)) (mime (ext->mime ext))) (serve-document-header mime) (cond ((file-executable? path) (serve-text-dynamic path)) ; Binary-files can also be generated here, but the source is dynamic text ((string-prefix? "text/" (car mime)) (serve-text-plain path)) (else (serve-binary path))))) (define (serve-text-plain path) (with-input-from-file path (lambda () (let loop ((str (read-string))) (unless (eof-object? str) (print* str) (loop (read-string))))))) (define (serve-text-dynamic path) (with-input-from-file path (lambda () (let loop ((c (peek-char))) (if (eof-object? c) 'done (begin (if (eq? c #\,) (begin (read-char) (serve-dynamic-element (read) (pathname-directory path)) (read-line)) (print (read-line))) (loop (peek-char)))))))) (define (serve-dynamic-element element working-directory) (match element (('eval expression) (with-current-working-directory working-directory (lambda () (eval expression eval-env)))) (('shell command) (with-current-working-directory working-directory (lambda () (let-values (((in-port out-port id) (process command))) (let ((string (read-string #f in-port))) (unless (eof-object? string) (print string)) (close-input-port in-port) (close-output-port out-port)))))) (else (error "Unknown element type.")))) (define (serve-script config uri) ;; Scripts are responsible for the entire response, including header (let* ((path (document-path config uri)) (proc (eval (with-input-from-file path read) eval-env))) (with-current-working-directory (pathname-directory (document-path config uri)) (lambda () (apply proc (list uri)))))) (define (with-current-working-directory directory thunk) (let ((old-wd (current-directory)) (result 'none)) (condition-case (begin (change-directory directory) (set! result (thunk)) (change-directory old-wd) result) (o (exn) (change-directory old-wd) (signal o))))) (define (run-server config) (set-buffering-mode! (current-output-port) #:line) (define listener (ssl-listen* port: (config-port config) certificate: (config-certfile config) private-key: (config-keyfile config) protocol: 'tlsv12)) (print "Host: '" (config-host config) "'\n" "Port: '" (config-port config) "'\n" "Root directory: '" (config-root-dir config) "'\n" "Cert file: '" (config-certfile config) "'\n" "Key file: '" (config-keyfile config) "'") (if (config-blacklist config) (print "Blacklist file: '" (config-blacklist config) "'")) (if (config-blacklist-resp config) (print "Blacklist responce file: '" (config-blacklist-resp config) "'")) (print) (print* "Dropping privilages ... ") (drop-privs config) (print "done") (print* "Setting up environment ... ") (setup-env config) (print "done") (print "\nGemini server listening ...") (server-loop listener config)) (define (setup-env config) (with-current-working-directory (config-root-dir config) (lambda () (if (and (file-exists? eval-env-file) (file-readable? eval-env-file)) (with-input-from-file eval-env-file (lambda () (let loop ((next-expr (read))) (unless (eof-object? next-expr) (eval next-expr eval-env) (loop (read)))))))))) (define (drop-privs config) (let ((uid (config-uid config)) (gid (config-gid config))) (if gid ; Group first, since only root can switch groups. (set! (current-group-id) gid)) (if uid (set! (current-user-id) uid)))) (define (server-loop listener config) (let-values (((in-port out-port) (ssl-accept listener))) (let-values (((local-ip remote-ip) (tcp-addresses (ssl-port->tcp-port in-port)))) (print (conc "Memory statistics: " (memory-statistics))) (print "Accepted connection from " remote-ip " on " (seconds->string)) (condition-case (if (and (config-blacklist config) (member remote-ip (with-input-from-file (config-blacklist config) read))) (begin (print "Connection from blacklisted IP. Closing.") (with-output-to-port out-port (lambda () (serve-document-header (ext->mime "txt")) (print "Refusing to serve to IP " remote-ip ".\n") (when (config-blacklist-resp config) (print) (for-each print (with-input-from-file (config-blacklist-resp config) read-lines)))))) (let ((request-line (read-line in-port))) (print* "Serving request '" request-line "' ... ") (with-output-to-port out-port (lambda () (process-request config request-line))) (print "done."))) (o (exn) (print-error-message o)))) (close-input-port in-port) (close-output-port out-port)) (server-loop listener config)) (define (print-usage progname) (let ((indent-str (make-string (string-length progname) #\space))) (print "Usage:\n" progname " [-h/--help]\n" progname " [-p/--port PORT] [-u/--user UID] [-g/--group GID]\n" indent-str " [-b/--blacklist FILE] [-r/--blacklist-resp RESPFILE]\n" indent-str " server-root-dir hostname certfile keyfile\n" "\n" "The -b option can be used to specify a FILE containing a list of IP addresses\n" "to block from the server. If a connection from a blocked address is served,\n" "the response file RESPFILE is served instead, if this is provided."))) (define (main) (let* ((progname (pathname-file (car (argv)))) (config (make-config #f #f 1965 #f #f #f #f #f #f))) (if (null? (command-line-arguments)) (print-usage progname) (let loop ((args (command-line-arguments))) (let ((this-arg (car args)) (rest-args (cdr args))) (if (string-prefix? "-" this-arg) (cond ((or (equal? this-arg "-h") (equal? this-arg "--help")) (print-usage progname)) ((or (equal? this-arg "-p") (equal? this-arg "--port")) (config-port-set! config (string->number (car rest-args))) (loop (cdr rest-args))) ((or (equal? this-arg "-u") (equal? this-arg "--user")) (config-uid-set! config (string->number (car rest-args))) (loop (cdr rest-args))) ((or (equal? this-arg "-g") (equal? this-arg "--group")) (config-gid-set! config (string->number (car rest-args))) (loop (cdr rest-args))) ((or (equal? this-arg "-b") (equal? this-arg "--blacklist")) (config-blacklist-set! config (car rest-args)) (loop (cdr rest-args))) ((or (equal? this-arg "-r") (equal? this-arg "--blacklist-resp")) (config-blacklist-resp-set! config (car rest-args)) (loop (cdr rest-args))) (else (print-usage progname))) (match args ((root-dir host certfile keyfile) (config-root-dir-set! config root-dir) (config-host-set! config host) (config-certfile-set! config certfile) (config-keyfile-set! config keyfile) (run-server config)) (else (print "One or more invalid arguments.") (print-usage progname))))))))) (main)