X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=rags.scm;h=8fb1bd93932439f82809f5c9a38beb7b795ecb40;hb=refs%2Fheads%2Fpatch_vhost;hp=2f3f8c1f4c43810850fe1e0fe176bdbfab60058b;hpb=65de3894d1e474b2f4574f7f23093712c9e8c537;p=rags.git diff --git a/rags.scm b/rags.scm index 2f3f8c1..8fb1bd9 100644 --- a/rags.scm +++ b/rags.scm @@ -1,7 +1,14 @@ ;; 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 irregex) (chicken port) (chicken file) (chicken string) @@ -10,15 +17,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 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)))) @@ -27,40 +44,88 @@ (fail-permanent "Unsupported scheme.")) ((not (uri-host uri)) (fail-permanent "URL lacks host name.")) - ((not (equal? (uri-host uri) (config-host config))) + ((not (valid-hostname (uri-host uri))) + (fail-permanent "Invalid host name.")) + ((not (existing-host config uri)) (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 (valid-hostname name) + (let* + ((host-label-part '(+ (or alphanumeric #\- #\_))) + (domain-part `(: #\. ,host-label-part)) + (hostname-regex `(: ,host-label-part (+ ,domain-part)))) + (irregex-match? hostname-regex name))) + +(define (existing-host config uri) + (directory-exists? (make-pathname (config-root-dir config) (uri-host 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) + (cons (uri-host uri) (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 +171,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)))) + (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)) @@ -120,12 +194,13 @@ (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" + (print "Port: '" (config-port config) "'\n" "Root directory: '" (config-root-dir config) "'\n" "Cert file: '" (config-certfile config) "'\n" @@ -133,8 +208,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,14 +240,18 @@ (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 certfile keyfile"))) (define (main) (let* ((progname (pathname-file (car (argv)))) - (config (make-config #f #f 1965 #f #f))) - (if (null? (cdr (argv))) + (config (make-config #f 1965 #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) @@ -172,14 +261,21 @@ (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))) (match args - ((root-dir host certfile keyfile) + ((root-dir 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))