gs.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         srfi-13)
  10
  11 (define gopher-root "./gopher-root")
  12 (define gopher-index-file-name "index")
  13 (define gopher-server-hostname "localhost")
  14 (define gopher-server-port 70)
  15
  16 (define (run-server)
  17   (print "Gopher server listening on port " gopher-server-port " ...")
  18   (let ((listener (tcp-listen gopher-server-port)))
  19     (let loop ()
  20       (let-values (((in-port out-port) (tcp-accept listener)))
  21         (let* ((line (read-line in-port))
  22                (selector (string-trim-both line)))
  23           (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
  24             (print "Accepted connection from " remote-ip
  25                    " on " (seconds->string)))
  26           (with-output-to-port out-port
  27             (lambda ()
  28               (serve-selector
  29                (if (= (string-length selector) 0)
  30                    "1/"
  31                    selector)
  32                gopher-root
  33                gopher-server-hostname
  34                gopher-server-port)))
  35           (print "... served selector '" selector "'. Closing connection."))
  36         (close-input-port in-port)
  37         (close-output-port out-port))
  38       (loop))
  39     (tcp-close listener)))
  40
  41 ;;; Selector retrieval
  42
  43 (define (serve-selector selector gopher-root server-host server-port)
  44   (let ((type (with-input-from-string (substring selector 0 1) read))
  45         (path (substring selector 1)))
  46     (case type
  47       ((0) (serve-text-file path server-host server-port))
  48       ((1) (serve-index-file path server-host server-port))
  49       ((9 g I) (serve-binary-file path server-host server-port))
  50       (else (error "Unhandled file type:" type)))))
  51
  52 (define (serve-index-file path server-host server-port)
  53   (let ((file-name (make-pathname (list gopher-root path) gopher-index-file-name)))
  54     (if (regular-file? file-name)
  55         (with-input-from-file file-name
  56           (lambda ()
  57             (render-index (read)
  58                           path
  59                           server-host
  60                           server-port)))
  61         (error "Index file not found."))))
  62
  63 (define (serve-text-file path server-host server-port)
  64   (let ((file-name (make-pathname gopher-root path)))
  65     (if (regular-file? file-name)
  66         (with-input-from-file file-name
  67           (lambda ()
  68             (for-each
  69              (lambda (line)
  70                (print line "\r"))
  71              (read-lines))))
  72         (error "File not found."))))
  73
  74 (define (serve-binary-file path server-host server-port)
  75   (let ((file-name (make-pathname gopher-root path)))
  76     (if (regular-file? file-name)
  77         (with-input-from-file file-name
  78           (lambda ()
  79             (let loop ((b (read-byte)))
  80               (if (eof-object? b)
  81                   'done
  82                   (begin
  83                     (write-byte b)
  84                     (loop (read-byte)))))))))
  85   (print "File not found."))
  86
  87 ;;; Index rendering
  88
  89 (define entry-type car)
  90
  91 (define entry-name cadr)
  92
  93 (define (has-selector? entry) (>= (length entry) 3))
  94
  95 (define (entry-selector entry) (list-ref entry 2))
  96
  97 (define (has-host? entry) (>= (length entry) 4))
  98
  99 (define (entry-host entry) (list-ref entry 3))
 100
 101 (define (has-port? entry) (>= (length entry) 5))
 102
 103 (define (entry-port entry) (list-ref entry 4))
 104
 105 (define (render-entry entry default-selector default-host default-port selector-prefix)
 106   (let ((name-string (entry-name entry)))
 107     (for-each
 108      (lambda (name-string-line)
 109        (print* (entry-type entry) name-string-line)
 110        (print* "\t" (if (has-selector? entry)
 111                         (if (has-host? entry)
 112                             (entry-selector entry)
 113                             (conc (entry-type entry)
 114                                   (make-pathname selector-prefix (entry-selector entry))))
 115                         default-selector))
 116        (print* "\t" (if (has-host? entry)
 117                         (entry-host entry)
 118                         default-host))
 119        (print* "\t" (if (has-port? entry)
 120                         (entry-port entry)
 121                         default-port))
 122        (print* "\r\n"))
 123      (string-split name-string "\n" #t))))
 124
 125 (define (render-index index selector-prefix this-host this-port)
 126   (for-each
 127    (lambda (entry)
 128      (if (eq? (entry-type entry) 'i)
 129          (render-entry entry "fake.selector" "fake.host" 1 selector-prefix)
 130          (render-entry entry "" this-host this-port selector-prefix)))
 131    index)
 132   (print "."))