burrower.scm

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