X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=rags.scm;h=ecc861854ea1ec771a2b388f8c5b08a0bb1b4166;hb=aadb0c8602819fe3dbaf7a283c4f7697f1971641;hp=2f3f8c1f4c43810850fe1e0fe176bdbfab60058b;hpb=65de3894d1e474b2f4574f7f23093712c9e8c537;p=rags.git diff --git a/rags.scm b/rags.scm index 2f3f8c1..ecc8618 100644 --- a/rags.scm +++ b/rags.scm @@ -1,5 +1,11 @@ ;; 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) @@ -10,15 +16,25 @@ (chicken time posix) (chicken process) (chicken process-context) - matchable srfi-13 + (chicken process-context posix) + 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) (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 (process-request config request-line) (let ((uri (uri-normalize-path-segments (absolute-uri request-line)))) @@ -33,34 +49,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))))) @@ -106,6 +157,12 @@ (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))) + (apply (eval (with-input-from-file path read)) + (list uri)))) + (define (with-current-working-directory directory thunk) (let ((old-wd (current-directory)) (result 'none)) @@ -120,10 +177,11 @@ (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" @@ -133,8 +191,18 @@ "\n" "Gemini server listening ...") + (drop-privs config) (server-loop listener config)) +(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)))) @@ -155,11 +223,15 @@ (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 " server-root-dir hostname certfile keyfile"))) (define (main) (let* ((progname (pathname-file (car (argv)))) - (config (make-config #f #f 1965 #f #f))) + (config (make-config #f #f 1965 #f #f #f #f))) (if (null? (cdr (argv))) (print-usage progname) (let loop ((args (cdr (argv)))) @@ -172,7 +244,15 @@ (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))) (else (print-usage progname)))