burrow.scm

   1 (import (chicken tcp)
   2         (chicken port)
   3         (chicken io)
   4         (chicken string)
   5         (chicken pathname)
   6         (chicken file posix)
   7         (chicken time posix)
   8         (chicken condition)
   9         (chicken process)
  10         (chicken process-context)
  11         srfi-1 srfi-13 matchable)
  12
  13 ;;; Global constants
  14
  15 (define gopher-index-file-name "index")
  16
  17 (define burrow-version "1.0.0")
  18
  19 (define burrow-footer
  20   (conc "\n"
  21         "--------------------------------------------------\n"
  22         "Served by Burrow Gopher Server v" burrow-version "\n"
  23         "Powered by Chicken Scheme!"))
  24
  25
  26 ;;; Server loop
  27
  28 ;; We don't yet use worker threads here to handle requests,
  29 ;; the server just blocks until the first request is finished.
  30 ;; While we should fix this, it's actually probably okay, as
  31 ;; we genuinely don't expect a huge flood of gopher traffic. :-(
  32
  33 (define-record config root-dir host port display-footer)
  34
  35 (define (run-server config)
  36   (print "Gopher server listening on port " (config-port config) " ...")
  37   (let ((listener (tcp-listen (config-port config))))
  38     (let server-loop ()
  39       (let-values (((in-port out-port) (tcp-accept listener)))
  40         (let* ((line (read-line in-port))
  41                (selector (string-trim-both line)))
  42           (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
  43             (print "Accepted connection from " remote-ip
  44                    " on " (seconds->string))
  45             (condition-case
  46                 (begin
  47                   (with-output-to-port out-port
  48                     (lambda ()
  49                       (serve-selector (if (= (string-length selector) 0)
  50                                           "/"
  51                                           selector)
  52                                       remote-ip config)))
  53                   (print "... served selector '" selector "'. Closing connection."))
  54               (o (exn)
  55                  (print-error-message o out-port)
  56                  (print-error-message o)
  57                  (print "Error while attempting to serve selector " selector ".")))))
  58         (close-input-port in-port)
  59         (close-output-port out-port))
  60       (server-loop))
  61     (tcp-close listener)))
  62
  63
  64 ;;; Selector type inference
  65
  66 (define (has-suffix? selector . suffixes)
  67   (if (null? suffixes)
  68       #f
  69       (if (string-suffix? (car suffixes) selector)
  70           #t
  71           (apply has-suffix? selector (cdr suffixes)))))
  72
  73 (define (infer-selector-type selector)
  74   (let ((l (string-downcase selector)))
  75     (cond
  76      ((or (= (string-length l) 0) (string-suffix? "/" l)) 1)
  77      ((has-suffix? l ".txt" ".org" ".md") 0)
  78      ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I)
  79      ((has-suffix? l "?") 7)
  80      (else 9))))
  81
  82
  83 ;;; Selector retrieval
  84
  85 (define (serve-selector raw-selector remote-ip config)
  86   (let* ((selector-list (string-split raw-selector "\t"))
  87          (selector (car selector-list))
  88          (arguments (cdr selector-list)))
  89     (case (infer-selector-type selector)
  90       ((1) (serve-directory selector config))
  91       ((0) (serve-text-file selector config))
  92       ((7) (serve-query selector arguments remote-ip config))
  93       (else (serve-binary-file selector config)))))
  94
  95 (define (serve-directory selector config)
  96   (let ((file-name (make-pathname (list (config-root-dir config) selector)
  97                                   gopher-index-file-name)))
  98     (if (regular-file? file-name)
  99         (begin
 100           (with-input-from-file file-name
 101             (lambda ()
 102               (let loop ((c (peek-char)))
 103                 (if (eof-object? c)
 104                     'done
 105                     (begin
 106                       (if (eq? c #\,)
 107                           (begin
 108                             (read-char)
 109                             (serve-record (read) selector config)
 110                             (read-line))
 111                           (serve-info-records (read-line)))
 112                       (loop (peek-char)))))))
 113           (if (config-display-footer config)
 114               (serve-info-records burrow-footer)))
 115         (error "Index file not found."))))
 116
 117 (define (serve-text-file selector config)
 118   (let ((file-name (make-pathname (config-root-dir config) selector)))
 119     (if (regular-file? file-name)
 120         (with-input-from-file file-name
 121           (lambda ()
 122             (for-each
 123              (lambda (line)
 124                (print line "\r"))
 125              (read-lines))))
 126         (error "File not found." file-name))))
 127
 128 (define (serve-binary-file selector config)
 129   (let ((file-name (make-pathname (config-root-dir config) selector)))
 130     (if (regular-file? file-name)
 131         (with-input-from-file file-name
 132           (lambda ()
 133             (let loop ((b (read-byte)))
 134               (if (eof-object? b)
 135                   'done
 136                   (begin
 137                     (write-byte b)
 138                     (loop (read-byte)))))))
 139         (error "File not found." file-name))))
 140
 141 (define (serve-query selector arguments remote-ip config)
 142   (let ((file-name (make-pathname (config-root-dir config)
 143                                   (conc (string-chomp selector "?") ".scm"))))
 144     (if (and (regular-file? file-name)
 145              (= (length arguments) 1))
 146         (with-input-from-file file-name
 147           (lambda ()
 148             (serve-info-records
 149              (with-selector-dir
 150               selector config
 151               (lambda ()
 152                 (apply (eval (read))
 153                        (list (car arguments) remote-ip)))))))
 154         (error "Invalid query."))))
 155
 156
 157 ;;; Index rendering
 158
 159 (define (serve-info-records string)
 160   (for-each
 161    (lambda (line)
 162      (print* "i")
 163      (for-each (lambda (char)
 164                  (print* (if (eq? char #\tab)
 165                              "    "
 166                              char)))
 167                (string->list line))
 168      (print "\tfake\tfake\t1\r"))
 169    (string-split string "\n" #t)))
 170
 171 (define (serve-record record dir-selector config)
 172   (match record
 173     (('shell command) (serve-shell-command command dir-selector config))
 174     (('eval expression) (serve-expression expression dir-selector config))
 175     (('url display-string url)
 176      (print #\h display-string "\tURL:" url "\tfake\t80\r"))
 177     ((type display-string selector host port)
 178      (print type display-string "\t" selector "\t" host "\t" port "\r"))
 179     ((type display-string selector host)
 180      (serve-record (list type display-string selector host 70)
 181                    dir-selector config))
 182     ((type display-string selector)
 183      (serve-record (list type display-string
 184                          (make-pathname dir-selector selector)
 185                          (config-host config) (config-port config))
 186                    dir-selector config))
 187     ((display-string selector)
 188      (serve-record (list (infer-selector-type selector) display-string selector)
 189                    dir-selector config))
 190     ((selector)
 191      (serve-record (list (infer-selecto-type selector) selector)
 192                    dir-selector config))
 193     (else (error "Unknown record type."))))
 194
 195 (define (serve-shell-command command dir-selector config)
 196   (with-selector-dir
 197    dir-selector config
 198    (lambda ()
 199      (let-values (((in-port out-port id) (process command)))
 200        (serve-info-records (string-chomp (read-string #f in-port) "\n"))))))
 201
 202 (define (serve-expression expression dir-selector config)
 203   (with-selector-dir
 204    dir-selector config
 205    (lambda ()
 206      (serve-info-records (conc (eval expression))))))
 207
 208
 209 ;;; Utility methods
 210
 211 (define (with-current-working-directory directory thunk)
 212   (let ((old-wd (current-directory))
 213         (result 'none))
 214     (change-directory directory)
 215     (set! result (thunk))
 216     (change-directory old-wd)
 217     result))
 218
 219 (define (with-selector-dir selector config thunk)
 220   (with-current-working-directory
 221    (make-pathname (config-root-dir config)
 222                   (pathname-directory selector)) thunk))
 223
 224 ;;; main
 225
 226 (define (print-usage progname)
 227   (print "Usage:\n"
 228          progname " -h/--help\n"
 229          progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n"
 230          "\n"
 231          "The -n option tells the server to not display a directory footer."))
 232
 233 (define (main)
 234   (let* ((progname (car (argv)))
 235          (args (cdr (argv)))
 236          (config (make-config '() '() 70 #t)))
 237
 238     (if (or (null? args)
 239             (equal? (car args) "-h")
 240             (equal? (car args) "--help"))
 241         (print-usage progname)
 242         (begin
 243           (if (or (equal? (car args) "-n")
 244                   (equal? (car args) "--no-footer"))
 245               (begin
 246                 (config-display-footer-set! config #f)
 247                 (set! args (cdr args))))
 248           (if (or (< (length args) 2)
 249                   (> (length args) 3))
 250               (print-usage progname)
 251               (begin
 252                 (config-root-dir-set! config (car args))
 253                 (config-host-set! config (cadr args))
 254                 (if (= (length args) 3)
 255                     (config-port-set! config (string->number (caddr args))))
 256                 (run-server config)))))))
 257
 258 (main)
 259
 260 ;; (define (test)
 261 ;;   (run-server (make-config "gopher-root" "localhost" 70 #t)))
 262
 263 ;; (test)