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 port)
  12         (chicken file)
  13         (chicken string)
  14         (chicken pathname)
  15         (chicken condition)
  16         (chicken time posix)
  17         (chicken process)
  18         (chicken process-context)
  19         (chicken process-context posix)
  20         (chicken gc)
  21         matchable srfi-13 srfi-1
  22         uri-common tcp6 openssl)
  23
  24 (define-record config
  25   root-dir host port certfile keyfile uid gid blacklist blacklist-resp)
  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 eval-env-file "eval-env.scm")
  41 (define eval-env (interaction-environment))
  42
  43 (define (process-request config request-line)
  44   (let ((uri (uri-normalize-path-segments (absolute-uri request-line))))
  45     (cond
  46      ((not (eq? (uri-scheme uri) 'gemini))
  47       (fail-permanent "Unsupported scheme."))
  48      ((not (uri-host uri))
  49       (fail-permanent "URL lacks host name."))
  50      ((not (equal? (uri-host uri) (config-host config)))
  51       (fail-permanent "Proxy requests forbidden."))
  52      ((uri-path-relative? uri)
  53       (fail-permanent "Path must be absolute."))
  54      ((not (document-available? config uri))
  55       (fail-permanent "Document not found."))
  56      ((and (document-path-directory? config uri)
  57            (uri-lacks-trailing-slash? uri))
  58       (redirect-permanent (uri-with-trailing-slash uri)))
  59      ((document-script? config uri)
  60       (serve-script config uri))
  61      (else
  62       (serve-document config uri)))))
  63
  64 (define (fail-permanent reason)
  65   (print "50 " reason "\r"))
  66
  67 (define (redirect-permanent new-uri)
  68   (print "30 " (uri->string new-uri) "\r"))
  69
  70 (define (serve-query prompt)
  71   (print "10 " prompt "\r"))
  72
  73 (define (uri-lacks-trailing-slash? uri)
  74   (not (string-null? (last (uri-path uri)))))
  75
  76 (define (uri-with-trailing-slash uri)
  77   (update-uri uri path: (append (uri-path uri) '(""))))
  78
  79 (define (document-available? config uri)
  80   (file-exists? (document-path config uri)))
  81
  82 (define (document-script? config uri)
  83   (let ((path (document-path config uri)))
  84     (and (file-exists? path)
  85          (file-executable? path)
  86          (equal? (pathname-extension path) "scm"))))
  87
  88 (define (document-path-directory? config uri)
  89   (directory-exists? (document-path-raw config uri)))
  90
  91 (define (document-path-raw config uri)
  92   (let* ((crumbs (reverse (cons (config-root-dir config) (cdr (uri-path uri))))))
  93     (make-pathname (reverse (cdr crumbs)) (car crumbs))))
  94
  95 (define (document-path config uri)
  96   (let* ((path (document-path-raw config uri)))
  97     (if (directory-exists? path)
  98         (make-pathname path "index.gmi")
  99         path)))
 100
 101 (define (ext->mime ext)
 102   (let* ((mime-detected (assoc ext file-types)))
 103     (cdr (if mime-detected
 104              mime-detected
 105              (assoc "txt" file-types)))))
 106
 107 (define (serve-document-header mime)
 108   (print "20 " (string-intersperse mime ";") "\r"))
 109
 110 (define (serve-document config uri)
 111   (let* ((path (document-path config uri))
 112          (ext (pathname-extension path))
 113          (mime (ext->mime ext)))
 114     (serve-document-header mime)
 115     (cond
 116      ((file-executable? path)
 117       (serve-text-dynamic path)) ; Binary-files can also be generated here, but the source is dynamic text
 118      ((string-prefix? "text/" (car mime))
 119       (serve-text-plain path))
 120      (else (serve-binary path)))))
 121
 122 (define (serve-text-plain path)
 123   (with-input-from-file path
 124     (lambda ()
 125       (let loop ((str (read-string)))
 126         (unless (eof-object? str)
 127           (print* str)
 128           (loop (read-string)))))))
 129
 130 (define (serve-text-dynamic path)
 131   (with-input-from-file path
 132     (lambda ()
 133       (let loop ((c (peek-char)))
 134         (if (eof-object? c)
 135             'done
 136             (begin
 137               (if (eq? c #\,)
 138                   (begin
 139                     (read-char)
 140                     (serve-dynamic-element (read) (pathname-directory path))
 141                     (read-line))
 142                   (print (read-line)))
 143               (loop (peek-char))))))))
 144
 145 (define (serve-dynamic-element element working-directory)
 146   (match element
 147     (('eval expression)
 148      (with-current-working-directory
 149       working-directory
 150       (lambda ()
 151         (eval expression eval-env))))
 152     (('shell command)
 153      (with-current-working-directory
 154       working-directory
 155       (lambda ()
 156         (let-values (((in-port out-port id) (process command)))
 157           (let ((string (read-string #f in-port)))
 158             (unless (eof-object? string)
 159               (print string))
 160             (close-input-port in-port)
 161             (close-output-port out-port))))))
 162     (else (error "Unknown element type."))))
 163
 164 (define (serve-script config uri)
 165   ;; Scripts are responsible for the entire response, including header
 166   (let* ((path (document-path config uri))
 167          (proc (eval (with-input-from-file path read) eval-env)))
 168     (with-current-working-directory
 169      (pathname-directory (document-path config uri))
 170      (lambda ()
 171        (apply proc (list uri))))))
 172
 173 (define (with-current-working-directory directory thunk)
 174   (let ((old-wd (current-directory))
 175         (result 'none))
 176     (condition-case
 177         (begin
 178           (change-directory directory)
 179           (set! result (thunk))
 180           (change-directory old-wd)
 181           result)
 182       (o (exn)
 183          (change-directory old-wd)
 184          (signal o)))))
 185
 186 (define (run-server config)
 187   (set-buffering-mode! (current-output-port) #:line)
 188   (define listener (ssl-listen* port: (config-port config)
 189                                 certificate: (config-certfile config)
 190                                 private-key: (config-keyfile config)
 191                                 protocol: 'tlsv12))
 192
 193   (print "Host: '" (config-host config) "'\n"
 194          "Port: '" (config-port config) "'\n"
 195          "Root directory: '" (config-root-dir config) "'\n"
 196          "Cert file: '" (config-certfile config) "'\n"
 197          "Key file: '" (config-keyfile config) "'\n")
 198
 199   (print* "Dropping privilages ... ")
 200   (drop-privs config)
 201   (print "done")
 202
 203   (print* "Setting up environment ... ")
 204   (setup-env config)
 205   (print "done")
 206
 207   (print "\nGemini server listening ...")
 208   (server-loop listener config))
 209
 210 (define (setup-env config)
 211   (with-current-working-directory
 212    (config-root-dir config)
 213    (lambda ()
 214      (if (and (file-exists? eval-env-file) (file-readable? eval-env-file))
 215          (with-input-from-file eval-env-file
 216            (lambda ()
 217              (let loop ((next-expr (read)))
 218                (unless (eof-object? next-expr)
 219                  (eval next-expr eval-env)
 220                  (loop (read))))))))))
 221
 222 (define (drop-privs config)
 223   (let ((uid (config-uid config))
 224         (gid (config-gid config)))
 225     (if gid ; Group first, since only root can switch groups.
 226         (set! (current-group-id) gid))
 227     (if uid
 228         (set! (current-user-id) uid))))
 229
 230
 231 (define (server-loop listener config)
 232   (let-values (((in-port out-port) (ssl-accept listener)))
 233     (let-values (((local-ip remote-ip) (tcp-addresses (ssl-port->tcp-port in-port))))
 234       (print (conc "Memory statistics: " (memory-statistics)))
 235       (print "Accepted connection from " remote-ip
 236              " on " (seconds->string))
 237       (condition-case
 238           (if (or (config-blacklist config)
 239                   (not (member remote-ip
 240                                (with-input-from-file
 241                                    (config-blacklist config)))))
 242               (let ((request-line (read-line in-port)))
 243                 (print* "Serving request '" request-line "' ... ")
 244                 (with-output-to-port out-port
 245                   (lambda ()
 246                     (process-request config request-line)))
 247                 (print "done."))
 248               (begin
 249                 (print "Connection from blacklisted IP. Closing.")
 250                 (with-output-to-port out-port
 251                   (lambda ()
 252                     (print* "Refusing to serve to IP " remote-ip ".\n")
 253                     (when (config-blacklist-resp config)
 254                       (for-each print
 255                                 (with-input-from-file
 256                                     (config-blacklist-resp config)
 257                                   read-lines)))))))
 258         (o (exn)
 259            (print-error-message o))))
 260     (close-input-port in-port)
 261     (close-output-port out-port))
 262   (server-loop listener config))
 263
 264
 265 (define (print-usage progname)
 266   (let ((indent-str (make-string (string-length progname) #\space)))
 267     (print "Usage:\n"
 268            progname " [-h/--help]\n"
 269            progname " [-p/--port PORT] [-u/--user UID] [-g/--group GID]\n"
 270            indent-str " server-root-dir hostname certfile keyfile")))
 271
 272 (define (main)
 273   (let* ((progname (pathname-file (car (argv))))
 274          (config (make-config #f #f 1965 #f #f #f #f #f #f)))
 275     (if (null? (command-line-arguments))
 276         (print-usage progname)
 277         (let loop ((args (command-line-arguments)))
 278           (let ((this-arg (car args))
 279                 (rest-args (cdr args)))
 280             (if (string-prefix? "-" this-arg)
 281                 (cond
 282                  ((or (equal? this-arg "-h")
 283                       (equal? this-arg "--help"))
 284                   (print-usage progname))
 285                  ((or (equal? this-arg "-p")
 286                       (equal? this-arg "--port"))
 287                   (config-port-set! config (string->number (car rest-args)))
 288                   (loop (cdr rest-args)))
 289                  ((or (equal? this-arg "-u")
 290                       (equal? this-arg "--user"))
 291                   (config-uid-set! config (string->number (car rest-args)))
 292                   (loop (cdr rest-args)))
 293                  ((or (equal? this-arg "-g")
 294                       (equal? this-arg "--group"))
 295                   (config-gid-set! config (string->number (car rest-args)))
 296                   (loop (cdr rest-args)))
 297                  ((or (equal? this-arg "-b")
 298                       (equal? this-arg "--blacklist"))
 299                   (config-blacklist-set! config (car rest-args))
 300                   (loop (cdr rest-args)))
 301                  ((or (equal? this-arg "-r")
 302                       (equal? this-arg "--blacklist-resp"))
 303                   (config-blacklist-resp-set! config (car rest-args))
 304                   (loop (cdr rest-args)))
 305                  (else
 306                   (print-usage progname)))
 307                 (match args
 308                   ((root-dir host certfile keyfile)
 309                    (config-root-dir-set! config root-dir)
 310                    (config-host-set! config host)
 311                    (config-certfile-set! config certfile)
 312                    (config-keyfile-set! config keyfile)
 313                    (run-server config))
 314                   (else
 315                    (print "One or more invalid arguments.")
 316                    (print-usage progname)))))))))
 317
 318 (main)