X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=rags.git;a=blobdiff_plain;f=rags.scm;h=febfd823f986ac4a36478c9c3904c16ad7a921db;hp=264f5537a66647d4f09d0a22cff39756b80c8687;hb=HEAD;hpb=f279ff3c0a93204a629e707fe54b0ee08921c579 diff --git a/rags.scm b/rags.scm index 264f553..febfd82 100644 --- a/rags.scm +++ b/rags.scm @@ -1,3 +1,12 @@ +;; 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) @@ -7,15 +16,29 @@ (chicken time posix) (chicken process) (chicken process-context) - matchable srfi-13 + (chicken process-context posix) + (chicken gc) + matchable srfi-13 srfi-1 uri-common tcp6 openssl) (define-record config - root-dir host port certfile keyfile) + 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"))) + ("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)))) @@ -30,34 +53,69 @@ (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* ((crumbs (reverse (cons (config-root-dir config) (cdr (uri-path uri))))) - (path (make-pathname (reverse (cdr crumbs)) (car crumbs)))) + (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-detected (assoc ext file-types)) - (mime (if mime-detected mime-detected (assoc "txt" file-types))) - (mime-type (cadr mime))) - (print "20 " (string-intersperse (cdr mime) ";") "\r") + (mime (ext->mime ext))) + (serve-document-header mime) (cond - ((and (equal? mime-type "text/gemini") - (file-executable? path)) - (serve-text-dynamic path)) - ((string-prefix? "text/" mime-type) + ((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))))) @@ -90,7 +148,7 @@ (with-current-working-directory working-directory (lambda () - (eval expression)))) + (eval expression eval-env)))) (('shell command) (with-current-working-directory working-directory @@ -103,6 +161,15 @@ (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)) @@ -117,33 +184,87 @@ (signal o))))) (define (run-server config) - (define listener (ssl-listen* hostname: (config-host config) - port: (config-port 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))) + 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) "'\n" - "\n" - "Gemini server listening ...") + "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 - (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.")) + (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) @@ -152,14 +273,23 @@ (define (print-usage progname) - (print "Usage: " progname " [-h] [-p port] server-root-dir hostname certfile keyfile")) + (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))) - (if (null? (cdr (argv))) + (config (make-config #f #f 1965 #f #f #f #f #f #f))) + (if (null? (command-line-arguments)) (print-usage progname) - (let loop ((args (cdr (argv)))) + (let loop ((args (command-line-arguments))) (let ((this-arg (car args)) (rest-args (cdr args))) (if (string-prefix? "-" this-arg) @@ -169,7 +299,23 @@ (print-usage progname)) ((or (equal? this-arg "-p") (equal? this-arg "--port")) - (config-port-set! config (string->bumber (car rest-args))) + (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)))