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-file-name "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 (has-suffix? selector . suffixes)
  72   (if (null? suffixes)
  73       #f
  74       (if (string-suffix? (car suffixes) selector)
  75           #t
  76           (apply has-suffix? selector (cdr suffixes)))))
  77
  78 (define (infer-selector-type selector)
  79   (let ((l (string-downcase selector)))
  80     (cond
  81      ((or (= (string-length l) 0) (string-suffix? "/" l)) 1)
  82      ((has-suffix? l ".txt" ".org" ".md") 0)
  83      ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I)
  84      ((has-suffix? l "?.scm") 7)
  85      (else 9))))
  86
  87
  88 ;;; Selector retrieval
  89
  90 (define (serve-selector raw-selector config)
  91   (let* ((selector-list (string-split raw-selector "\t"))
  92          (selector (car selector-list))
  93          (arguments (cdr selector-list)))
  94     (case (infer-selector-type selector)
  95       ((1) (serve-directory selector config))
  96       ((0) (serve-text-file selector config))
  97       ((7) (serve-query selector arguments config))
  98       (else (serve-binary-file selector config)))))
  99
 100 (define (serve-directory selector config)
 101   (let ((file-name (make-pathname (list (config-root-dir config) selector)
 102                                   gopher-index-file-name)))
 103     (if (regular-file? file-name)
 104         (begin
 105           (with-input-from-file file-name
 106             (lambda ()
 107               (let loop ((c (peek-char)))
 108                 (if (eof-object? c)
 109                     'done
 110                     (begin
 111                       (if (eq? c #\,)
 112                           (begin
 113                             (read-char)
 114                             (serve-record (read) selector config)
 115                             (read-line))
 116                           (serve-info-records (read-line)))
 117                       (loop (peek-char)))))))
 118           (if (config-display-footer config)
 119               (serve-info-records burrower-footer)))
 120         (error "Index file not found."))))
 121
 122 (define (serve-text-file selector config)
 123   (let ((file-name (make-pathname (config-root-dir config) selector)))
 124     (if (regular-file? file-name)
 125         (with-input-from-file file-name
 126           (lambda ()
 127             (for-each
 128              (lambda (line)
 129                (print line "\r"))
 130              (read-lines))))
 131         (error "File not found." file-name))))
 132
 133 (define (serve-binary-file selector config)
 134   (let ((file-name (make-pathname (config-root-dir config) selector)))
 135     (if (regular-file? file-name)
 136         (with-input-from-file file-name
 137           (lambda ()
 138             (let loop ((b (read-byte)))
 139               (if (eof-object? b)
 140                   'done
 141                   (begin
 142                     (write-byte b)
 143                     (loop (read-byte)))))))
 144         (error "File not found." file-name))))
 145
 146 (define (serve-query selector arguments config)
 147   (let ((file-name (make-pathname (config-root-dir config) selector)))
 148     (if (and (regular-file? file-name)
 149              (= (length arguments) 1))
 150         (with-input-from-file file-name
 151           (lambda ()
 152             (serve-info-records
 153              (with-selector-dir
 154               selector config
 155               (lambda ()
 156                 (apply (eval (read)) arguments))))))
 157         (error "Invalid query." selector arguments))))
 158
 159
 160 ;;; Index rendering
 161
 162 (define (serve-info-records string)
 163   (for-each
 164    (lambda (line)
 165      (print* "i")
 166      (for-each (lambda (char)
 167                  (print* (if (eq? char #\tab)
 168                              "    "
 169                              char)))
 170                (string->list line))
 171      (print "\tfake\tfake\t1\r"))
 172    (string-split string "\n" #t)))
 173
 174 (define (serve-record record dir-selector config)
 175   (match record
 176     (('shell command) (serve-shell-command command dir-selector config))
 177     (('eval expression) (serve-expression expression dir-selector config))
 178     (('url display-string url)
 179      (print #\h display-string "\tURL:" url
 180             "\t" (config-host config)
 181             "\t" (config-port config) "\r"))
 182     ((type display-string selector host port)
 183      (print type display-string "\t" selector "\t" host "\t" port "\r"))
 184     ((type display-string selector host)
 185      (serve-record (list type display-string selector host 70)
 186                    dir-selector config))
 187     ((type display-string selector)
 188      (serve-record (list type display-string
 189                          (make-pathname dir-selector selector)
 190                          (config-host config) (config-port config))
 191                    dir-selector config))
 192     ((display-string selector)
 193      (serve-record (list (infer-selector-type selector) display-string selector)
 194                    dir-selector config))
 195     ((selector)
 196      (serve-record (list (infer-selecto-type selector) selector)
 197                    dir-selector config))
 198     (else (error "Unknown record type."))))
 199
 200 (define (serve-shell-command command dir-selector config)
 201   (with-selector-dir
 202    dir-selector config
 203    (lambda ()
 204      (let-values (((in-port out-port id) (process command)))
 205        (let ((string (read-string #f in-port)))
 206          (if (and (not (eof-object? string))
 207                   (> (string-length string) 0))
 208              (serve-info-records (string-chomp string "\n"))))))))
 209
 210 (define (serve-expression expression dir-selector config)
 211   (with-selector-dir
 212    dir-selector config
 213    (lambda ()
 214      (serve-info-records (conc (eval expression))))))
 215
 216
 217 ;;; Utility methods
 218
 219 (define (with-current-working-directory directory thunk)
 220   (let ((old-wd (current-directory))
 221         (result 'none))
 222     (condition-case
 223         (begin
 224           (change-directory directory)
 225           (set! result (thunk))
 226           (change-directory old-wd)
 227           result)
 228       (o (exn)
 229          (change-directory old-wd)
 230          (signal o)))))
 231
 232 (define (with-selector-dir selector config thunk)
 233   (with-current-working-directory
 234    (make-pathname (config-root-dir config)
 235                   (pathname-directory selector)) thunk))
 236
 237 ;;; main
 238
 239 (define (print-usage progname)
 240   (print "Usage:\n"
 241          progname " -h/--help\n"
 242          progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n"
 243          "\n"
 244          "The -n option tells the server to not display a directory footer."))
 245
 246 (define (main)
 247   (let* ((progname (car (argv)))
 248          (args (cdr (argv)))
 249          (config (make-config '() '() 70 #t)))
 250
 251     (if (or (null? args)
 252             (equal? (car args) "-h")
 253             (equal? (car args) "--help"))
 254         (print-usage progname)
 255         (begin
 256           (if (or (equal? (car args) "-n")
 257                   (equal? (car args) "--no-footer"))
 258               (begin
 259                 (config-display-footer-set! config #f)
 260                 (set! args (cdr args))))
 261           (if (or (< (length args) 2)
 262                   (> (length args) 3))
 263               (print-usage progname)
 264               (begin
 265                 (config-root-dir-set! config (car args))
 266                 (config-host-set! config (cadr args))
 267                 (if (= (length args) 3)
 268                     (config-port-set! config (string->number (caddr args))))
 269                 (run-server config)))))))
 270
 271 (main)
 272
 273 ;; (define (test)
 274 ;;   (run-server (make-config "gopher-root" "localhost" 70 #t)))
 275
 276 ;; (test)