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