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 (define gopher-index-file-name "index")
  14
  15 (define burrow-version "1.0.0")
  16
  17 (define burrow-footer
  18   (conc "\n"
  19         "--------------------------------------------------\n"
  20         "Served by Burrow Gopher Server v" burrow-version "\n"
  21         "Powered by Chicken Scheme!"))
  22
  23 ;;; Server loop
  24 ;; We don't actually use worker threads here to handle requests,
  25 ;; the server just blocks until the first request is finished.
  26
  27 (define-record config root-dir host port display-footer)
  28
  29 (define (run-server config)
  30   (print "Gopher server listening on port " (config-port config) " ...")
  31   (let ((listener (tcp-listen (config-port config))))
  32     (let server-loop ()
  33       (let-values (((in-port out-port) (tcp-accept listener)))
  34         (let* ((line (read-line in-port))
  35                (selector (string-trim-both line)))
  36           (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
  37             (print "Accepted connection from " remote-ip
  38                    " on " (seconds->string)))
  39           (condition-case
  40               (begin
  41                 (with-output-to-port out-port
  42                   (lambda ()
  43                     (serve-selector (if (= (string-length selector) 0)
  44                                         "/"
  45                                         selector)
  46                                     config)))
  47                 (print "... served selector '" selector "'. Closing connection."))
  48             (o (exn)
  49                (print-error-message o out-port)
  50                (print-error-message o)
  51                (print "Error while attempting to serve selector " selector "."))))
  52         (close-input-port in-port)
  53         (close-output-port out-port))
  54       (server-loop))
  55     (tcp-close listener)))
  56
  57 ;;; Selector type inference
  58
  59 (define (has-suffix? selector . suffixes)
  60   (if (null? suffixes)
  61       #f
  62       (if (string-suffix? (car suffixes) selector)
  63           #t
  64           (apply has-suffix? selector (cdr suffixes)))))
  65
  66 (define (infer-selector-type selector)
  67   (let ((l (string-downcase selector)))
  68     (cond
  69      ((or (= (string-length l) 0) (string-suffix? "/" l)) 1)
  70      ((has-suffix? l ".txt" ".org" ".md") 0)
  71      ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I)
  72      (else 9))))
  73
  74 ;;; Selector retrieval
  75
  76 (define (serve-selector selector config)
  77   ((case (infer-selector-type selector)
  78      ((1) serve-directory)
  79      ((0) serve-text-file)
  80      (else serve-binary-file))
  81    selector config))
  82
  83 (define (serve-directory path config)
  84   (let ((file-name (make-pathname (list (config-root-dir config) path)
  85                                   gopher-index-file-name)))
  86     (if (regular-file? file-name)
  87         (begin
  88           (with-input-from-file file-name
  89             (lambda ()
  90               (let loop ((c (peek-char)))
  91                 (if (eof-object? c)
  92                     'done
  93                     (begin
  94                       (if (eq? c #\,)
  95                           (begin
  96                             (read-char)
  97                             (serve-record (read) path config)
  98                             (read-line))
  99                           (serve-info-records (read-line)))
 100                       (loop (peek-char)))))))
 101           (if (config-display-footer config)
 102               (serve-info-records burrow-footer)))
 103         (error "Index file not found."))))
 104
 105 (define (serve-text-file path config)
 106   (let ((file-name (make-pathname (config-root-dir config) path)))
 107     (if (regular-file? file-name)
 108         (with-input-from-file file-name
 109           (lambda ()
 110             (for-each
 111              (lambda (line)
 112                (print line "\r"))
 113              (read-lines))))
 114         (error "File not found." file-name))))
 115
 116 (define (serve-binary-file path config)
 117   (let ((file-name (make-pathname (config-root-dir config) path)))
 118     (if (regular-file? file-name)
 119         (with-input-from-file file-name
 120           (lambda ()
 121             (let loop ((b (read-byte)))
 122               (if (eof-object? b)
 123                   'done
 124                   (begin
 125                     (write-byte b)
 126                     (loop (read-byte)))))))
 127         (error "File not found." file-name))))
 128
 129
 130 ;;; Index rendering
 131
 132 (define (serve-info-records string)
 133   (for-each
 134    (lambda (line)
 135      (print* "i")
 136      (for-each (lambda (char)
 137                  (print* (if (eq? char #\tab)
 138                              "    "
 139                              char)))
 140                (string->list line))
 141      (print "\tfake\tfake\t1\r"))
 142    (string-split string "\n" #t)))
 143
 144 (define (serve-record record path config)
 145   (match record
 146     (('shell command) (serve-shell-command command))
 147     (('eval expression) (serve-expression expression))
 148     (('url display-string url)
 149      (print #\h display-string "\tURL:" url "\tfake\t80\r"))
 150     ((type display-string selector host port)
 151      (print type display-string "\t" selector "\t" host "\t" port "\r"))
 152     ((type display-string selector host)
 153      (serve-record (list type display-string selector host 70)
 154                    path config))
 155     ((type display-string selector)
 156      (serve-record (list type display-string selector
 157                          (config-host config) (config-port config))
 158                    path config))
 159     ((display-string selector)
 160      (serve-record (list (infer-selector-type selector) display-string selector)
 161                    path config))
 162     ((selector)
 163      (serve-record (list (infer-selecto-type selector) selector)
 164                    path config))
 165     (else (error "Unknown record type."))))
 166
 167 (define (serve-shell-command command)
 168   (let-values (((in-port out-port id) (process command)))
 169     (serve-info-records (string-chomp (read-string #f in-port) "\n"))))
 170
 171 (define (serve-expression expression)
 172   (serve-info-records (conc (eval expression))))
 173
 174 ;;; main
 175
 176 (define (print-usage progname)
 177   (print "Usage:\n"
 178          progname " -h/--help\n"
 179          progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n"
 180          "\n"
 181          "The -n option tells the server to not display a directory footer."))
 182
 183 (define (main)
 184   (let* ((progname (car (argv)))
 185          (args (cdr (argv)))
 186          (config (make-config '() '() 70 #t)))
 187
 188     (if (or (null? args)
 189             (equal? (car args) "-h")
 190             (equal? (car args) "--help"))
 191         (print-usage progname)
 192         (begin
 193           (if (or (equal? (car args) "-n")
 194                   (equal? (car args) "--no-footer"))
 195               (begin
 196                 (config-display-footer-set! config #f)
 197                 (set! args (cdr args))))
 198           (print args)
 199           (if (or (< (length args) 2)
 200                   (> (length args) 3))
 201               (print-usage progname)
 202               (begin
 203                 (config-root-dir-set! config (car args))
 204                 (config-host-set! config (cadr args))
 205                 (if (= (length args) 3)
 206                     (config-port-set! config (string->number (caddr args))))
 207                 (run-server config)))))))
 208
 209 (main)
 210
 211 ;; (define (test)
 212 ;;   (run-server (make-config "gopher-root" "localhost" 70 #t)))
 213
 214 ;; (test)