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     ((type display-string selector host port)
 149      (print type display-string "\t" selector "\t" host "\t" port "\r"))
 150     ((type display-string selector host)
 151      (serve-record (list type display-string selector host 70)
 152                    path config))
 153     ((type display-string selector)
 154      (serve-record (list type display-string selector
 155                          (config-host config) (config-port config))
 156                    path config))
 157     ((display-string selector)
 158      (serve-record (list (infer-selector-type selector) display-string selector)
 159                    path config))
 160     ((selector)
 161      (serve-record (list (infer-selecto-type selector) selector)
 162                    path config))
 163     (else (error "Unknown record type."))))
 164
 165 (define (serve-shell-command command)
 166   (let-values (((in-port out-port id) (process command)))
 167     (serve-info-records (string-chomp (read-string #f in-port) "\n"))))
 168
 169 (define (serve-expression expression)
 170   (serve-info-records (conc (eval expression))))
 171
 172 ;;; main
 173
 174 (define (print-usage progname)
 175   (print "Usage:\n"
 176          progname " -h/--help\n"
 177          progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n"
 178          "\n"
 179          "The -n option tells the server to not display a directory footer."))
 180
 181 (define (main)
 182   (let* ((progname (car (argv)))
 183          (args (cdr (argv)))
 184          (config (make-config '() '() 70 #t)))
 185
 186     (if (or (null? args)
 187             (equal? (car args) "-h")
 188             (equal? (car args) "--help"))
 189         (print-usage progname)
 190         (begin
 191           (if (or (equal? (car args) "-n")
 192                   (equal? (car args) "--no-footer"))
 193               (begin
 194                 (config-display-footer-set! config #f)
 195                 (set! args (cdr args))))
 196           (print args)
 197           (if (or (< (length args) 2)
 198                   (> (length args) 3))
 199               (print-usage progname)
 200               (begin
 201                 (config-root-dir-set! config (car args))
 202                 (config-host-set! config (cadr args))
 203                 (if (= (length args) 3)
 204                     (config-port-set! config (string->number (caddr args))))
 205                 (run-server config)))))))
 206
 207 ;; (main)
 208
 209 (define (test)
 210   (run-server (make-config "gopher-root" "localhost" 70 #t)))
 211
 212 ;; (test)