From a636a257f0e7509a4da85e6e8a6113cf7e46b83a Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Sat, 23 May 2020 22:37:16 +0200 Subject: [PATCH] Server serving over TLS. --- gratchy.scm | 142 ++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 110 insertions(+), 32 deletions(-) diff --git a/gratchy.scm b/gratchy.scm index 3ddb540..9424a38 100644 --- a/gratchy.scm +++ b/gratchy.scm @@ -1,52 +1,130 @@ (import (chicken io) + (chicken port) (chicken file) + (chicken string) (chicken pathname) (chicken condition) - uri-common) + (chicken process-context) + matchable srfi-13 + uri-common openssl) (define SERVER-ROOT "public_gemini") -(define SERVER-HOST "thelambdalab.xyz") +(define SERVER-HOST "localhost") +(define SERVER-HOST 1965) + +(define-record config + root-dir host port certfile keyfile) (define file-types - '(("gmi" "text/gemini; charset=utf8") - ("txt" "text/plain; charset=utf8"))) - -(define (process-request request-line) - (condition-case - (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) SERVER-HOST)) - (fail-permanent "Proxy requests forbidden.")) - ((uri-path-relative? uri) - (fail-permanent "Path must be absolute.")) - ((not (document-available? uri)) - (fail-permanent "Document not found.")) - (else (serve-document uri)))) - (o (exn) - (print o) - (fail-permanent "Failed to parse URL.")))) + '(("gmi" "text/gemini" "charset=utf-8") + ("txt" "text/plain" "charset=utf-8"))) + +(define (process-request config request-line) + ;; (condition-case + (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.")) + (else + (serve-document config uri))))) + ;; (o (exn) + ;; (print ((condition-property-accessor 'exn 'message) o)) + ;; (fail-permanent "Failed to parse URL.")))) (define (fail-permanent reason) (print "50 " reason "\r")) -(define (document-available? uri) - (print (document-path uri)) - (file-exists? (document-path uri))) +(define (document-available? config uri) + (file-exists? (document-path config uri))) -(define (document-path uri) - (let* ((crumbs (reverse (cons SERVER-ROOT (cdr (uri-path uri))))) +(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)))) (if (directory-exists? path) (make-pathname path "index.gmi") path))) -(define (serve-document uri) - (let ((path (document-path uri))) - (print "20 Surprise!\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") + (cond + ((equal? mime-type "text/gemini") (serve-text-plain path)) + ((equal? mime-type "text/plain") (serve-text-plain path)) + (else (serve-binary))))) + +(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 (run-server config) + (define listener (ssl-listen (config-port config))) + + (ssl-load-certificate-chain! listener (config-certfile config)) + (ssl-load-private-key! listener (config-keyfile config)) + + (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 ...") + + (let-values (((in-port out-port) (ssl-accept listener))) + (let ((request-line (read-line in-port))) + (with-output-to-port out-port + (lambda () + (process-request config request-line)))))) + +(define (print-usage progname) + (print "Usage: " progname " [-h] [-p port] server-root-dir hostname certfile keyfile")) + +(define (main) + (let* ((progname (pathname-file (car (argv)))) + (config (make-config #f #f 1965 #f #f))) + (if (null? (cdr (argv))) + (print-usage progname) + (let loop ((args (cdr (argv)))) + (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->bumber (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))))))))) -(process-request "gemini://thelambdalab.xyz//") +(main) -- 2.20.1