burrower.scm

   1 ;;; Burrower gopher server
   2 ;;
   3 ;; Requires Chicken 5.0.0.
   4 ;;
   5
   6 ;;; Imports
   7
   8 (import (chicken tcp)
   9         (chicken port)
  10         (chicken io)
  11         (chicken string)
  12         (chicken pathname)
  13         (chicken file)
  14         (chicken time posix)
  15         (chicken condition)
  16         (chicken process)
  17         (chicken process-context)
  18         (chicken process-context posix)
  19         srfi-1 srfi-13 matchable)
  20
  21 ;;; Global constants
  22
  23 (define burrower-version "1.0.0")
  24
  25 (define burrower-footer
  26   (conc "\n"
  27         "--------------------------------------------------\n"
  28         "This gopher hole was dug using Burrower v" burrower-version ".\n"
  29         "Powered by Chicken Scheme!"))
  30
  31 (define gopher-index-filename "index")
  32
  33 ;;; Server loop
  34
  35 ;; We don't yet use worker threads here to handle requests,
  36 ;; the server just blocks until the first request is finished.
  37 ;; While we should fix this, it's actually probably okay, as
  38 ;; we genuinely don't expect a huge flood of gopher traffic. :-(
  39
  40 (define-record config
  41   root-dir host port display-footer user group)
  42
  43 (define (run-server config)
  44   (set-buffering-mode! (current-output-port) #:line)
  45   (let ((listener (tcp-listen (config-port config))))
  46     (print "Gopher server listening on port " (config-port config) " ...")
  47     (drop-privs config)
  48     (server-loop listener config))
  49   (tcp-close listener))
  50
  51 (define (drop-privs config)
  52   (let ((uid (config-user config))
  53         (gid (config-group config)))
  54     (if (not (null? gid)) ; Group first, since only root can switch groups.
  55         (set! (current-group-id) gid))
  56     (if (not (null? uid))
  57         (set! (current-user-id) uid))))
  58
  59 (define (server-loop listener config)
  60   (let-values (((in-port out-port) (tcp-accept listener)))
  61     (let* ((line (read-line in-port))
  62            (selector (string-trim-both line)))
  63       (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
  64         (print "Accepted connection from " remote-ip
  65                " on " (seconds->string))
  66         (condition-case
  67             (begin
  68               (with-output-to-port out-port
  69                 (lambda ()
  70                   (serve-selector (if (= (string-length selector) 0)
  71                                       "/"
  72                                       selector)
  73                                   config)))
  74               (print "... served selector '" selector "'. Closing connection."))
  75           (o (exn)
  76              (print-error-message o out-port)
  77              (print-error-message o)
  78              (print "Error while attempting to serve selector " selector ".")))))
  79     (close-input-port in-port)
  80     (close-output-port out-port))
  81   (server-loop listener config))
  82
  83 ;;; Selector type inference
  84
  85 (define (true-for-one? predicate values)
  86   (if (null? values)
  87       #f
  88       (if (predicate (car values))
  89           #t
  90           (true-for-one? predicate (cdr values)))))
  91
  92 (define (has-suffix? selector . suffixes)
  93   (true-for-one? (lambda (suffix)
  94                    (string-suffix? suffix selector))
  95                  suffixes))
  96
  97 (define (has-prefix? selector . prefixes)
  98   (true-for-one? (lambda (prefix)
  99                    (string-prefix? prefix selector))
 100                  prefixes))
 101
 102 (define (infer-selector-type selector)
 103   (let ((l (string-downcase selector)))
 104     (cond
 105      ((or (= (string-length l) 0)
 106           (string-suffix? "/" l)
 107           (string-contains l ":")) 1)
 108      ((has-suffix? l ".txt" ".org" ".md") 0)
 109      ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I)
 110      ((has-suffix? l "?" "%3f") 7)
 111      ((has-prefix? l "url:" "/url:") 'h)
 112      (else 9))))
 113
 114
 115 ;;; Selector retrieval
 116
 117 (define (serve-selector raw-selector config)
 118   (let* ((selector-list (string-split raw-selector "\t"))
 119          (selector (car selector-list))
 120          (arguments (cdr selector-list)))
 121     (if (string-contains selector ":")
 122         (let ((l (string-split selector ":")))
 123           (serve-script (car l) (cdr l) config))
 124         (case (infer-selector-type selector)
 125           ((1) (serve-directory-file selector config))
 126           ((7) (let ((l (string-split selector "?")))
 127                  (serve-script (car l) arguments config)))
 128           ((0) (serve-text-file selector config))
 129           ((h) (serve-url selector config))
 130           (else (serve-binary-file selector config))))))
 131
 132 (define (legal-filename? filename config)
 133   (and (string-prefix? (config-root-dir config)
 134                        (normalize-pathname filename))
 135        (file-exists? filename)
 136        (not (directory-exists? filename))
 137        (file-readable? filename)))
 138
 139 (define (legal-script-filename? filename config)
 140   (and (legal-filename? filename config)
 141        (string-suffix? ".scm" filename)
 142        (file-executable? filename)))
 143
 144 (define (serve-directory-file selector config)
 145   (let ((filename (make-pathname (list (config-root-dir config) selector)
 146                                  gopher-index-filename)))
 147     (if (legal-filename? filename config)
 148         (begin
 149           (with-input-from-file filename
 150             (lambda ()
 151               (let loop ((c (peek-char)))
 152                 (if (eof-object? c)
 153                     'done
 154                     (begin
 155                       (if (eq? c #\,)
 156                           (begin
 157                             (read-char)
 158                             (serve-record (read) selector config)
 159                             (read-line))
 160                           (serve-info-records (read-line)))
 161                       (loop (peek-char)))))))
 162           (if (config-display-footer config)
 163               (serve-info-records burrower-footer))
 164           (print ".\r"))
 165         (error "No legal index file not found."))))
 166
 167 (define (serve-text-file selector config)
 168   (let ((filename (make-pathname (config-root-dir config) selector)))
 169     (if (legal-filename? filename config)
 170         (begin
 171           (with-input-from-file filename
 172             (lambda ()
 173               (for-each
 174                (lambda (line)
 175                  (print line "\r"))
 176                (read-lines))))
 177           (print ".\r"))
 178         (error "File not found." filename))))
 179
 180 (define (serve-binary-file selector config)
 181   (let ((filename (make-pathname (config-root-dir config) selector)))
 182     (if (legal-filename? filename config)
 183         (with-input-from-file filename
 184           (lambda ()
 185             (let loop ((b (read-byte)))
 186               (if (eof-object? b)
 187                   'done
 188                   (begin
 189                     (write-byte b)
 190                     (loop (read-byte)))))))
 191         (error "File not found." filename))))
 192
 193 (define (serve-url selector config)
 194   (let ((url (substring selector 4)))
 195     (print
 196      "<html><head><title>Redirection</title>"
 197      "<meta http-equiv=\"refresh\" content=\"10; URL='" url "'\" />"
 198      "</head><body>"
 199      "<p>If you are seeing this page, your gopher browser does not "
 200      "properly support URL directory entries or cannot follow such "
 201      "links.</p>"
 202      "<p>If you are viewing this page using a web browser, you should "
 203      "be redirected shortly.  Otherwise, you can manually open the "
 204      "the follwing url:\n"
 205      "\n"
 206      "<a href=\"" url "\">" url "</a>\n"
 207      "</body></html>")))
 208
 209 (define (serve-script selector arguments config)
 210   (let ((filename (make-pathname (config-root-dir config) selector)))
 211     (if (legal-script-filename? filename config)
 212         (let* ((sexp (with-input-from-file filename read))
 213                (script-result (with-selector-dir
 214                                selector config
 215                                (lambda ()
 216                                  (apply (eval sexp) arguments)))))
 217           (when (pair? script-result)
 218             (serve-records script-result
 219                            (pathname-directory selector) config)
 220             (print ".\r")))
 221         (error "No legal index script not found." filename))))
 222
 223
 224 ;;; Index rendering
 225
 226 (define (serve-records records dir-selector config)
 227   (for-each
 228    (lambda (record)
 229      (serve-record record dir-selector config))
 230    records))
 231
 232 (define (serve-info-records string)
 233   (for-each
 234    (lambda (line)
 235      (print* "i")
 236      (for-each (lambda (char)
 237                  (print* (if (eq? char #\tab)
 238                              "    "
 239                              char)))
 240                (string->list line))
 241      (print "\tfake\tfake\t1\r"))
 242    (string-split string "\n" #t)))
 243
 244 (define (serve-record record dir-selector config)
 245   (match record
 246     ((? string?) (serve-info-records record))
 247     (('shell command) (serve-shell-command command dir-selector config))
 248     (('eval expression) (serve-expression expression dir-selector config))
 249     (('url display-string url)
 250      (print #\h display-string "\tURL:" url
 251             "\t" (config-host config)
 252             "\t" (config-port config) "\r"))
 253     ((type display-string selector host port)
 254      (print type display-string "\t" selector "\t" host "\t" port "\r"))
 255     ((type display-string selector host)
 256      (serve-record (list type display-string selector host 70)
 257                    dir-selector config))
 258     ((type display-string selector)
 259      (serve-record (list type display-string
 260                          (make-pathname dir-selector selector)
 261                          (config-host config) (config-port config))
 262                    dir-selector config))
 263     ((display-string selector)
 264      (serve-record (list (infer-selector-type selector) display-string selector)
 265                    dir-selector config))
 266     ((selector)
 267      (serve-record (list (infer-selector-type selector) selector)
 268                    dir-selector config))
 269     (else (error "Unknown record type."))))
 270
 271 (define (serve-shell-command command dir-selector config)
 272   (with-selector-dir
 273    dir-selector config
 274    (lambda ()
 275      (let-values (((in-port out-port id) (process command)))
 276        (let ((string (read-string #f in-port)))
 277          (if (and (not (eof-object? string))
 278                   (> (string-length string) 0))
 279              (serve-info-records (string-chomp string "\n")))
 280          (close-input-port in-port)
 281          (close-output-port out-port))))))
 282
 283 (define (serve-expression expression dir-selector config)
 284   (with-selector-dir
 285    dir-selector config
 286    (lambda ()
 287      (serve-records (eval expression) dir-selector config))))
 288
 289
 290 ;;; Utility methods
 291
 292 (define (with-current-working-directory directory thunk)
 293   (let ((old-wd (current-directory))
 294         (result 'none))
 295     (condition-case
 296         (begin
 297           (change-directory directory)
 298           (set! result (thunk))
 299           (change-directory old-wd)
 300           result)
 301       (o (exn)
 302          (change-directory old-wd)
 303          (signal o)))))
 304
 305 (define (with-selector-dir selector config thunk)
 306   (with-current-working-directory
 307    (make-pathname (config-root-dir config)
 308                   (pathname-directory selector)) thunk))
 309
 310
 311 ;;; Main
 312
 313 (define (print-usage progname)
 314   (print "Usage:\n"
 315          progname " -h/--help\n"
 316          progname " [-n/--no-footer] [-u/--user UID] [-g/--group GID] root-dir hostname [port]\n"
 317          "\n"
 318          "The -n option tells the server to not display a directory footer."
 319          "The -u and -g can be used to set the UID and GID of the process following"
 320          "the creation of the TCP port listener (which often requires root)."))
 321
 322 (define (main)
 323   (let* ((progname (car (argv)))
 324          (config (make-config '() '() 70 #t '() '())))
 325     (if (null? (cdr (argv)))
 326         (print-usage progname)
 327         (let loop ((args (cdr (argv))))
 328           (let ((this-arg (car args))
 329                 (rest-args (cdr args)))
 330             (if (string-prefix? "-" this-arg)
 331                 (cond
 332                  ((or (equal? this-arg "-h")
 333                       (equal? this-arg "--help"))
 334                   (print-usage progname))
 335                  ((or (equal? this-arg "-n")
 336                       (equal? this-arg "--no-footer"))
 337                   (config-display-footer-set! config #f)
 338                   (loop rest-args))
 339                  ((or (equal? this-arg "-u")
 340                       (equal? this-arg "--user"))
 341                   (config-user-set! config (string->number (car rest-args)))
 342                   (loop (cdr rest-args)))
 343                  ((or (equal? this-arg "-g")
 344                       (equal? this-arg "--group"))
 345                   (config-group-set! config (string->number (car rest-args)))
 346                   (loop (cdr rest-args)))
 347                  (else
 348                   (print-usage progname)))
 349                 (begin
 350                   (config-root-dir-set! config (car args))
 351                   (config-host-set! config (cadr args))
 352                   (if (>= (length rest-args) 2)
 353                       (config-port-set! config (string->number (caddr args))))
 354                   (run-server config))))))))
 355
 356 (main)
 357
 358 ;; (define (test)
 359 ;;   (run-server (make-config "gopher-root" "localhost" 70 #t '() '())))
 360
 361 ;; (test)