rags.scm

   1 ;; The Right-Awful Gemini Server
   2 ;;
   3 ;; This is a gemini server in the spirit of the
   4 ;; scratchy gopher server.  Just as for that server,
   5 ;; rags uses runtime evaluation of embedded scheme
   6 ;; expressions to provide dynamically generated content.
   7 ;;
   8 ;; See the readme for details.
   9
  10 (import (chicken io)
  11         (chicken irregex)
  12         (chicken port)
  13         (chicken file)
  14         (chicken string)
  15         (chicken pathname)
  16         (chicken condition)
  17         (chicken time posix)
  18         (chicken process)
  19         (chicken process-context)
  20         (chicken process-context posix)
  21         matchable srfi-13 srfi-1
  22         uri-common tcp6 openssl)
  23
  24 (define-record config
  25   root-dir port certfile keyfile uid gid)
  26
  27 (define file-types
  28   '(("gmi" "text/gemini" "charset=utf-8")
  29     ("txt" "text/plain" "charset=utf-8")
  30     ("csv" "text/csv" "charset=utf-8")
  31     ("html" "text/html" "charset=utf-8")
  32     ("xml" "text/xml" "charset=utf-8")
  33     ("pdf" "application/pdf")
  34     ("zip" "application/zip")
  35     ("jpg" "image/jpeg")
  36     ("jpeg" "image/jpeg")
  37     ("png" "image/png")
  38     ("mp3" "audio/mpeg")))
  39
  40 (define (process-request config request-line)
  41   (let ((uri (uri-normalize-path-segments (absolute-uri request-line))))
  42     (cond
  43      ((not (eq? (uri-scheme uri) 'gemini))
  44       (fail-permanent "Unsupported scheme."))
  45      ((not (uri-host uri))
  46       (fail-permanent "URL lacks host name."))
  47      ((not (valid-hostname (uri-host uri)))
  48       (fail-permanent "Invalid host name."))
  49      ((not (existing-host config uri))
  50       (fail-permanent "Proxy requests forbidden."))
  51      ((uri-path-relative? uri)
  52       (fail-permanent "Path must be absolute."))
  53      ((not (document-available? config uri))
  54       (fail-permanent "Document not found."))
  55      ((and (document-path-directory? config uri)
  56            (uri-lacks-trailing-slash? uri))
  57       (redirect-permanent (uri-with-trailing-slash uri)))
  58      ((document-script? config uri)
  59       (serve-script config uri))
  60      (else
  61       (serve-document config uri)))))
  62
  63 (define (fail-permanent reason)
  64   (print "50 " reason "\r"))
  65
  66 (define (redirect-permanent new-uri)
  67   (print "30 " (uri->string new-uri) "\r"))
  68
  69 (define (serve-query prompt)
  70   (print "10 " prompt "\r"))
  71
  72 (define (uri-lacks-trailing-slash? uri)
  73   (not (string-null? (last (uri-path uri)))))
  74
  75 (define (uri-with-trailing-slash uri)
  76   (update-uri uri path: (append (uri-path uri) '(""))))
  77
  78 (define (valid-hostname name)
  79   (let*
  80     ((host-label-part '(+ (or alphanumeric #\- #\_)))
  81       (domain-part `(: #\. ,host-label-part))
  82       (hostname-regex `(: ,host-label-part (+ ,domain-part))))
  83     (irregex-match? hostname-regex name)))
  84
  85 (define (existing-host config uri)
  86   (directory-exists? (make-pathname (config-root-dir config) (uri-host uri))))
  87
  88 (define (document-available? config uri)
  89   (file-exists? (document-path config uri)))
  90
  91 (define (document-script? config uri)
  92   (let ((path (document-path config uri)))
  93     (and (file-exists? path)
  94          (file-executable? path)
  95          (equal? (pathname-extension path) "scm"))))
  96
  97 (define (document-path-directory? config uri)
  98   (directory-exists? (document-path-raw config uri)))
  99
 100 (define (document-path-raw config uri)
 101   (let* ((crumbs (reverse (cons (config-root-dir config)
 102                             (cons (uri-host uri) (cdr (uri-path uri)))))))
 103     (make-pathname (reverse (cdr crumbs)) (car crumbs))))
 104
 105 (define (document-path config uri)
 106   (let* ((path (document-path-raw config uri)))
 107     (if (directory-exists? path)
 108         (make-pathname path "index.gmi")
 109         path)))
 110
 111 (define (ext->mime ext)
 112   (let* ((mime-detected (assoc ext file-types)))
 113     (cdr (if mime-detected
 114              mime-detected
 115              (assoc "txt" file-types)))))
 116
 117 (define (serve-document-header mime)
 118   (print "20 " (string-intersperse mime ";") "\r"))
 119
 120 (define (serve-document config uri)
 121   (let* ((path (document-path config uri))
 122          (ext (pathname-extension path))
 123          (mime (ext->mime ext)))
 124     (serve-document-header mime)
 125     (cond
 126      ((file-executable? path)
 127       (serve-text-dynamic path)) ; Binary-files can also be generated here, but the source is dynamic text
 128      ((string-prefix? "text/" (car mime))
 129       (serve-text-plain path))
 130      (else (serve-binary path)))))
 131
 132 (define (serve-text-plain path)
 133   (with-input-from-file path
 134     (lambda ()
 135       (let loop ((str (read-string)))
 136         (unless (eof-object? str)
 137           (print* str)
 138           (loop (read-string)))))))
 139
 140 (define (serve-text-dynamic path)
 141   (with-input-from-file path
 142     (lambda ()
 143       (let loop ((c (peek-char)))
 144         (if (eof-object? c)
 145             'done
 146             (begin
 147               (if (eq? c #\,)
 148                   (begin
 149                     (read-char)
 150                     (serve-dynamic-element (read) (pathname-directory path))
 151                     (read-line))
 152                   (print (read-line)))
 153               (loop (peek-char))))))))
 154
 155 (define (serve-dynamic-element element working-directory)
 156   (match element
 157     (('eval expression)
 158      (with-current-working-directory
 159       working-directory
 160       (lambda ()
 161         (eval expression))))
 162     (('shell command)
 163      (with-current-working-directory
 164       working-directory
 165       (lambda ()
 166         (let-values (((in-port out-port id) (process command)))
 167           (let ((string (read-string #f in-port)))
 168             (unless (eof-object? string)
 169               (print string))
 170             (close-input-port in-port)
 171             (close-output-port out-port))))))
 172     (else (error "Unknown element type."))))
 173
 174 (define (serve-script config uri)
 175   ;; Scripts are responsible for the entire response, including header
 176   (let* ((path (document-path config uri))
 177          (proc (eval (with-input-from-file path read))))
 178     (with-current-working-directory
 179      (pathname-directory (document-path config uri))
 180      (lambda ()
 181        (apply proc (list uri))))))
 182
 183 (define (with-current-working-directory directory thunk)
 184   (let ((old-wd (current-directory))
 185         (result 'none))
 186     (condition-case
 187         (begin
 188           (change-directory directory)
 189           (set! result (thunk))
 190           (change-directory old-wd)
 191           result)
 192       (o (exn)
 193          (change-directory old-wd)
 194          (signal o)))))
 195
 196 (define (run-server config)
 197   (set-buffering-mode! (current-output-port) #:line)
 198   (define listener (ssl-listen* port: (config-port config)
 199                                 certificate: (config-certfile config)
 200                                 private-key: (config-keyfile config)
 201                                 protocol: 'tlsv12))
 202
 203   (print
 204          "Port: '" (config-port config) "'\n"
 205          "Root directory: '" (config-root-dir config) "'\n"
 206          "Cert file: '" (config-certfile config) "'\n"
 207          "Key file: '" (config-keyfile config) "'\n"
 208          "\n"
 209          "Gemini server listening ...")
 210
 211   (drop-privs config)
 212   (server-loop listener config))
 213
 214 (define (drop-privs config)
 215   (let ((uid (config-uid config))
 216         (gid (config-gid config)))
 217     (if gid ; Group first, since only root can switch groups.
 218         (set! (current-group-id) gid))
 219     (if uid
 220         (set! (current-user-id) uid))))
 221
 222
 223 (define (server-loop listener config)
 224   (let-values (((in-port out-port) (ssl-accept listener)))
 225     (let-values (((local-ip remote-ip) (tcp-addresses (ssl-port->tcp-port in-port))))
 226       (print "Accepted connection from " remote-ip
 227              " on " (seconds->string))
 228       (condition-case
 229           (let ((request-line (read-line in-port)))
 230             (print* "Serving request '" request-line "' ... ")
 231             (with-output-to-port out-port
 232               (lambda ()
 233                 (process-request config request-line)))
 234             (print "done."))
 235         (o (exn)
 236            (print-error-message o))))
 237     (close-input-port in-port)
 238     (close-output-port out-port))
 239   (server-loop listener config))
 240
 241
 242 (define (print-usage progname)
 243   (let ((indent-str (make-string (string-length progname) #\space)))
 244     (print "Usage:\n"
 245            progname " [-h/--help]\n"
 246            progname " [-p/--port PORT] [-u/--user UID] [-g/--group GID]\n"
 247            indent-str " server-root-dir certfile keyfile")))
 248
 249 (define (main)
 250   (let* ((progname (pathname-file (car (argv))))
 251          (config (make-config #f 1965 #f #f #f #f)))
 252     (if (null? (command-line-arguments))
 253         (print-usage progname)
 254         (let loop ((args (command-line-arguments)))
 255           (let ((this-arg (car args))
 256                 (rest-args (cdr args)))
 257             (if (string-prefix? "-" this-arg)
 258                 (cond
 259                  ((or (equal? this-arg "-h")
 260                       (equal? this-arg "--help"))
 261                   (print-usage progname))
 262                  ((or (equal? this-arg "-p")
 263                       (equal? this-arg "--port"))
 264                   (config-port-set! config (string->number (car rest-args)))
 265                   (loop (cdr rest-args)))
 266                  ((or (equal? this-arg "-u")
 267                       (equal? this-arg "--user"))
 268                   (config-uid-set! config (string->number (car rest-args)))
 269                   (loop (cdr rest-args)))
 270                  ((or (equal? this-arg "-g")
 271                       (equal? this-arg "--group"))
 272                   (config-gid-set! config (string->number (car rest-args)))
 273                   (loop (cdr rest-args)))
 274                  (else
 275                   (print-usage progname)))
 276                 (match args
 277                   ((root-dir certfile keyfile)
 278                    (config-root-dir-set! config root-dir)
 279                    (config-certfile-set! config certfile)
 280                    (config-keyfile-set! config keyfile)
 281                    (run-server config))
 282                   (else
 283                    (print "One or more invalid arguments.")
 284                    (print-usage progname)))))))))
 285
 286 (main)