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