gratchy.scm

   1 (import (chicken io)
   2         (chicken port)
   3         (chicken file)
   4         (chicken string)
   5         (chicken pathname)
   6         (chicken condition)
   7         (chicken process-context)
   8         matchable srfi-13
   9         uri-common openssl)
  10
  11 (define SERVER-ROOT "public_gemini")
  12 (define SERVER-HOST "localhost")
  13 (define SERVER-HOST 1965)
  14
  15 (define-record config
  16   root-dir host port certfile keyfile)
  17
  18 (define file-types
  19   '(("gmi" "text/gemini" "charset=utf-8")
  20     ("txt" "text/plain" "charset=utf-8")))
  21
  22 (define (process-request config request-line)
  23   ;; (condition-case
  24   (let ((uri (uri-normalize-path-segments (absolute-uri request-line))))
  25     (cond
  26      ((not (eq? (uri-scheme uri) 'gemini))
  27       (fail-permanent "Unsupported scheme."))
  28      ((not (uri-host uri))
  29       (fail-permanent "URL lacks host name."))
  30      ((not (equal? (uri-host uri) (config-host config)))
  31       (fail-permanent "Proxy requests forbidden."))
  32      ((uri-path-relative? uri)
  33       (fail-permanent "Path must be absolute."))
  34      ((not (document-available? config uri))
  35       (fail-permanent "Document not found."))
  36      (else
  37       (serve-document config uri)))))
  38   ;; (o (exn)
  39   ;;    (print ((condition-property-accessor 'exn 'message) o))
  40   ;;    (fail-permanent "Failed to parse URL."))))
  41
  42 (define (fail-permanent reason)
  43   (print "50 " reason "\r"))
  44
  45 (define (document-available? config uri)
  46   (file-exists? (document-path config uri)))
  47
  48 (define (document-path config uri)
  49   (let* ((crumbs (reverse (cons (config-root-dir config) (cdr (uri-path uri)))))
  50          (path (make-pathname (reverse (cdr crumbs)) (car crumbs))))
  51     (if (directory-exists? path)
  52         (make-pathname path "index.gmi")
  53         path)))
  54
  55 (define (serve-document config uri)
  56   (let* ((path (document-path config uri))
  57          (ext (pathname-extension path))
  58          (mime-detected (assoc ext file-types))
  59          (mime (if mime-detected mime-detected (assoc "txt" file-types)))
  60          (mime-type (cadr mime)))
  61     (print "20 " (string-intersperse (cdr mime) ";") "\r")
  62     (cond
  63       ((equal? mime-type "text/gemini") (serve-text-plain path))
  64       ((equal? mime-type "text/plain") (serve-text-plain path))
  65       (else (serve-binary)))))
  66
  67 (define (serve-text-plain path)
  68   (with-input-from-file path
  69     (lambda ()
  70       (let loop ((str (read-string)))
  71         (unless (eof-object? str)
  72           (print* str)
  73           (loop (read-string)))))))
  74
  75
  76 (define (run-server config)
  77   (define listener (ssl-listen (config-port config)))
  78
  79   (ssl-load-certificate-chain! listener (config-certfile config))
  80   (ssl-load-private-key! listener (config-keyfile config))
  81
  82   (print "Host: '" (config-host config) "'\n"
  83          "Port: '" (config-port config) "'\n"
  84          "Root directory: '" (config-root-dir config) "'\n"
  85          "Cert file: '" (config-certfile config) "'\n"
  86          "Key file: '" (config-keyfile config) "'\n"
  87          "\n"
  88          "Gemini server listening ...")
  89
  90   (let-values (((in-port out-port) (ssl-accept listener)))
  91     (let ((request-line (read-line in-port)))
  92       (with-output-to-port out-port
  93         (lambda ()
  94           (process-request config request-line))))))
  95
  96 (define (print-usage progname)
  97   (print "Usage: " progname " [-h] [-p port] server-root-dir hostname certfile keyfile"))
  98
  99 (define (main)
 100   (let* ((progname (pathname-file (car (argv))))
 101          (config (make-config #f #f 1965 #f #f)))
 102     (if (null? (cdr (argv)))
 103         (print-usage progname)
 104         (let loop ((args (cdr (argv))))
 105           (let ((this-arg (car args))
 106                 (rest-args (cdr args)))
 107             (if (string-prefix? "-" this-arg)
 108                 (cond
 109                  ((or (equal? this-arg "-h")
 110                       (equal? this-arg "--help"))
 111                   (print-usage progname))
 112                  ((or (equal? this-arg "-p")
 113                       (equal? this-arg "--port"))
 114                   (config-port-set! config (string->bumber (car rest-args)))
 115                   (loop (cdr rest-args)))
 116                  (else
 117                   (print-usage progname)))
 118                 (match args
 119                   ((root-dir host certfile keyfile)
 120                    (config-root-dir-set! config root-dir)
 121                    (config-host-set! config host)
 122                    (config-certfile-set! config certfile)
 123                    (config-keyfile-set! config keyfile)
 124                    (run-server config))
 125                   (else
 126                    (print "One or more invalid arguments.")
 127                    (print-usage progname)))))))))
 128
 129
 130 (main)