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 (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 (serve-directory selector config)
 113   (let ((file-name (make-pathname (list (config-root-dir config) selector)
 114                                   gopher-index-file-name)))
 115     (if (regular-file? file-name)
 116         (begin
 117           (with-input-from-file file-name
 118             (lambda ()
 119               (let loop ((c (peek-char)))
 120                 (if (eof-object? c)
 121                     'done
 122                     (begin
 123                       (if (eq? c #\,)
 124                           (begin
 125                             (read-char)
 126                             (serve-record (read) selector config)
 127                             (read-line))
 128                           (serve-info-records (read-line)))
 129                       (loop (peek-char)))))))
 130           (if (config-display-footer config)
 131               (serve-info-records burrower-footer)))
 132         (error "Index file not found."))))
 133
 134 (define (serve-text-file selector config)
 135   (let ((file-name (make-pathname (config-root-dir config) selector)))
 136     (if (regular-file? file-name)
 137         (with-input-from-file file-name
 138           (lambda ()
 139             (for-each
 140              (lambda (line)
 141                (print line "\r"))
 142              (read-lines))))
 143         (error "File not found." file-name))))
 144
 145 (define (serve-binary-file selector config)
 146   (let ((file-name (make-pathname (config-root-dir config) selector)))
 147     (if (regular-file? file-name)
 148         (with-input-from-file file-name
 149           (lambda ()
 150             (let loop ((b (read-byte)))
 151               (if (eof-object? b)
 152                   'done
 153                   (begin
 154                     (write-byte b)
 155                     (loop (read-byte)))))))
 156         (error "File not found." file-name))))
 157
 158 (define (serve-query selector arguments config)
 159   (let ((file-name (make-pathname (config-root-dir config) selector)))
 160     (if (and (regular-file? file-name)
 161              (= (length arguments) 1))
 162         (with-input-from-file file-name
 163           (lambda ()
 164             (serve-info-records
 165              (with-selector-dir
 166               selector config
 167               (lambda ()
 168                 (apply (eval (read)) arguments))))))
 169         (error "Invalid query." selector arguments))))
 170
 171
 172 (define (serve-url selector config)
 173   (let ((url (substring selector 4)))
 174     (print
 175      "If you are seeing this page, your gopher browser does not\r\n"
 176      "properly support URL directory entries or cannot follow such\r\n"
 177      "links.  To view the link you requested, use a web browser to\r\n"
 178      "open the follwing url:\r\n"
 179      "\r\n"
 180      url "\r\n")))
 181
 182
 183 ;;; Index rendering
 184
 185 (define (serve-info-records string)
 186   (for-each
 187    (lambda (line)
 188      (print* "i")
 189      (for-each (lambda (char)
 190                  (print* (if (eq? char #\tab)
 191                              "    "
 192                              char)))
 193                (string->list line))
 194      (print "\tfake\tfake\t1\r"))
 195    (string-split string "\n" #t)))
 196
 197 (define (serve-record record dir-selector config)
 198   (match record
 199     (('shell command) (serve-shell-command command dir-selector config))
 200     (('eval expression) (serve-expression expression dir-selector config))
 201     (('url display-string url)
 202      (print #\h display-string "\tURL:" url
 203             "\t" (config-host config)
 204             "\t" (config-port config) "\r"))
 205     ((type display-string selector host port)
 206      (print type display-string "\t" selector "\t" host "\t" port "\r"))
 207     ((type display-string selector host)
 208      (serve-record (list type display-string selector host 70)
 209                    dir-selector config))
 210     ((type display-string selector)
 211      (serve-record (list type display-string
 212                          (make-pathname dir-selector selector)
 213                          (config-host config) (config-port config))
 214                    dir-selector config))
 215     ((display-string selector)
 216      (serve-record (list (infer-selector-type selector) display-string selector)
 217                    dir-selector config))
 218     ((selector)
 219      (serve-record (list (infer-selecto-type selector) selector)
 220                    dir-selector config))
 221     (else (error "Unknown record type."))))
 222
 223 (define (serve-shell-command command dir-selector config)
 224   (with-selector-dir
 225    dir-selector config
 226    (lambda ()
 227      (let-values (((in-port out-port id) (process command)))
 228        (let ((string (read-string #f in-port)))
 229          (if (and (not (eof-object? string))
 230                   (> (string-length string) 0))
 231              (serve-info-records (string-chomp string "\n"))))))))
 232
 233 (define (serve-expression expression dir-selector config)
 234   (with-selector-dir
 235    dir-selector config
 236    (lambda ()
 237      (serve-info-records (conc (eval expression))))))
 238
 239
 240 ;;; Utility methods
 241
 242 (define (with-current-working-directory directory thunk)
 243   (let ((old-wd (current-directory))
 244         (result 'none))
 245     (condition-case
 246         (begin
 247           (change-directory directory)
 248           (set! result (thunk))
 249           (change-directory old-wd)
 250           result)
 251       (o (exn)
 252          (change-directory old-wd)
 253          (signal o)))))
 254
 255 (define (with-selector-dir selector config thunk)
 256   (with-current-working-directory
 257    (make-pathname (config-root-dir config)
 258                   (pathname-directory selector)) thunk))
 259
 260 ;;; main
 261
 262 (define (print-usage progname)
 263   (print "Usage:\n"
 264          progname " -h/--help\n"
 265          progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n"
 266          "\n"
 267          "The -n option tells the server to not display a directory footer."))
 268
 269 (define (main)
 270   (let* ((progname (car (argv)))
 271          (args (cdr (argv)))
 272          (config (make-config '() '() 70 #t)))
 273
 274     (if (or (null? args)
 275             (equal? (car args) "-h")
 276             (equal? (car args) "--help"))
 277         (print-usage progname)
 278         (begin
 279           (if (or (equal? (car args) "-n")
 280                   (equal? (car args) "--no-footer"))
 281               (begin
 282                 (config-display-footer-set! config #f)
 283                 (set! args (cdr args))))
 284           (if (or (< (length args) 2)
 285                   (> (length args) 3))
 286               (print-usage progname)
 287               (begin
 288                 (config-root-dir-set! config (car args))
 289                 (config-host-set! config (cadr args))
 290                 (if (= (length args) 3)
 291                     (config-port-set! config (string->number (caddr args))))
 292                 (run-server config)))))))
 293
 294 (main)
 295
 296 ;; (define (test)
 297 ;;   (run-server (make-config "gopher-root" "localhost" 70 #t)))
 298
 299 ;; (test)