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) "'")
 198
 199   (if (config-blacklist config)
 200       (print "Blacklist file: '" (config-blacklist config) "'"))
 201   (if (config-blacklist-resp config)
 202       (print "Blacklist responce file: '" (config-blacklist-resp config) "'"))
 203
 204   (print)
 205
 206   (print* "Dropping privilages ... ")
 207   (drop-privs config)
 208   (print "done")
 209
 210   (print* "Setting up environment ... ")
 211   (setup-env config)
 212   (print "done")
 213
 214   (print "\nGemini server listening ...")
 215   (server-loop listener config))
 216
 217 (define (setup-env config)
 218   (with-current-working-directory
 219    (config-root-dir config)
 220    (lambda ()
 221      (if (and (file-exists? eval-env-file) (file-readable? eval-env-file))
 222          (with-input-from-file eval-env-file
 223            (lambda ()
 224              (let loop ((next-expr (read)))
 225                (unless (eof-object? next-expr)
 226                  (eval next-expr eval-env)
 227                  (loop (read))))))))))
 228
 229 (define (drop-privs config)
 230   (let ((uid (config-uid config))
 231         (gid (config-gid config)))
 232     (if gid ; Group first, since only root can switch groups.
 233         (set! (current-group-id) gid))
 234     (if uid
 235         (set! (current-user-id) uid))))
 236
 237
 238 (define (server-loop listener config)
 239   (let-values (((in-port out-port) (ssl-accept listener)))
 240     (let-values (((local-ip remote-ip) (tcp-addresses (ssl-port->tcp-port in-port))))
 241       (print (conc "Memory statistics: " (memory-statistics)))
 242       (print "Accepted connection from " remote-ip
 243              " on " (seconds->string))
 244       (condition-case
 245           (if (and (config-blacklist config)
 246                    (member remote-ip
 247                            (with-input-from-file
 248                                (config-blacklist config)
 249                              read)))
 250               (begin
 251                 (print "Connection from blacklisted IP. Closing.")
 252                 (with-output-to-port out-port
 253                   (lambda ()
 254                     (serve-document-header (ext->mime "txt"))
 255                     (print "Refusing to serve to IP " remote-ip ".\n")
 256                     (when (config-blacklist-resp config)
 257                       (print)
 258                       (for-each print
 259                                 (with-input-from-file
 260                                     (config-blacklist-resp config)
 261                                   read-lines))))))
 262               (let ((request-line (read-line in-port)))
 263                 (print* "Serving request '" request-line "' ... ")
 264                 (with-output-to-port out-port
 265                   (lambda ()
 266                     (process-request config request-line)))
 267                 (print "done.")))
 268         (o (exn)
 269            (print-error-message o))))
 270     (close-input-port in-port)
 271     (close-output-port out-port))
 272   (server-loop listener config))
 273
 274
 275 (define (print-usage progname)
 276   (let ((indent-str (make-string (string-length progname) #\space)))
 277     (print "Usage:\n"
 278            progname " [-h/--help]\n"
 279            progname " [-p/--port PORT] [-u/--user UID] [-g/--group GID]\n"
 280            indent-str " [-b/--blacklist FILE] [-r/--blacklist-resp RESPFILE]\n"
 281            indent-str " server-root-dir hostname certfile keyfile\n"
 282            "\n"
 283            "The -b option can be used to specify a FILE containing a list of IP addresses\n"
 284            "to block from the server. If a connection from a blocked address is served,\n"
 285            "the response file RESPFILE is served instead, if this is provided.")))
 286
 287 (define (main)
 288   (let* ((progname (pathname-file (car (argv))))
 289          (config (make-config #f #f 1965 #f #f #f #f #f #f)))
 290     (if (null? (command-line-arguments))
 291         (print-usage progname)
 292         (let loop ((args (command-line-arguments)))
 293           (let ((this-arg (car args))
 294                 (rest-args (cdr args)))
 295             (if (string-prefix? "-" this-arg)
 296                 (cond
 297                  ((or (equal? this-arg "-h")
 298                       (equal? this-arg "--help"))
 299                   (print-usage progname))
 300                  ((or (equal? this-arg "-p")
 301                       (equal? this-arg "--port"))
 302                   (config-port-set! config (string->number (car rest-args)))
 303                   (loop (cdr rest-args)))
 304                  ((or (equal? this-arg "-u")
 305                       (equal? this-arg "--user"))
 306                   (config-uid-set! config (string->number (car rest-args)))
 307                   (loop (cdr rest-args)))
 308                  ((or (equal? this-arg "-g")
 309                       (equal? this-arg "--group"))
 310                   (config-gid-set! config (string->number (car rest-args)))
 311                   (loop (cdr rest-args)))
 312                  ((or (equal? this-arg "-b")
 313                       (equal? this-arg "--blacklist"))
 314                   (config-blacklist-set! config (car rest-args))
 315                   (loop (cdr rest-args)))
 316                  ((or (equal? this-arg "-r")
 317                       (equal? this-arg "--blacklist-resp"))
 318                   (config-blacklist-resp-set! config (car rest-args))
 319                   (loop (cdr rest-args)))
 320                  (else
 321                   (print-usage progname)))
 322                 (match args
 323                   ((root-dir host certfile keyfile)
 324                    (config-root-dir-set! config root-dir)
 325                    (config-host-set! config host)
 326                    (config-certfile-set! config certfile)
 327                    (config-keyfile-set! config keyfile)
 328                    (run-server config))
 329                   (else
 330                    (print "One or more invalid arguments.")
 331                    (print-usage progname)))))))))
 332
 333 (main)