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)
  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
  55 ;;; Selector retrieval
  56
  57 (define (directory-selector? selector)
  58   (string-suffix? "/" selector))
  59
  60 (define (text-selector? selector)
  61   (apply or (map (lambda (ext) (string-suffix? ext selector))
  62                  '(".txt" ".org" ".md"))))
  63
  64 (define (serve-selector selector config)
  65   ((cond
  66     ((directory-selector? selector) serve-directory)
  67     ((text-selector? seletor) serve-text-file)
  68     (else serve-binary-file))
  69    selector config))
  70
  71 (define (serve-directory path config)
  72   (let ((file-name (make-pathname (list (server-root-dir config) path)
  73                                   gopher-index-file-name)))
  74     (if (regular-file? file-name)
  75         (with-input-from-file file-name
  76           (lambda ()
  77             (let loop ((c (peek-char)))
  78               (if (eof-object? c)
  79                   'done
  80                   (begin
  81                     (if (eq? c #\,)
  82                         (begin
  83                           (read-char)
  84                           (serve-record (read) path config)
  85                           (read-line))
  86                         (serve-info-record (read-line)))
  87                     (loop (peek-char)))))))
  88         (error "Index file not found."))))
  89
  90 (define (serve-text-file path config)
  91   (let ((file-name (make-pathname (server-root-dir config) path)))
  92     (if (regular-file? file-name)
  93         (with-input-from-file file-name
  94           (lambda ()
  95             (for-each
  96              (lambda (line)
  97                (print line "\r"))
  98              (read-lines))))
  99         (error "File not found." file-name))))
 100
 101 (define (serve-binary-file path config)
 102   (let ((file-name (make-pathname (server-root-dir config) path)))
 103     (if (regular-file? file-name)
 104         (with-input-from-file file-name
 105           (lambda ()
 106             (let loop ((b (read-byte)))
 107               (if (eof-object? b)
 108                   'done
 109                   (begin
 110                     (write-byte b)
 111                     (loop (read-byte)))))))
 112         (error "File not found." file-name))))
 113
 114
 115 ;;; Index rendering
 116
 117 (define (serve-info-record info-string)
 118   (print "i" info-string "\tfake\tfake\t1\r"))
 119
 120 ;;; main
 121
 122 (define (main)
 123   (let ((progname (car (argv)))
 124         (args (cdr (argv))))
 125     (if (or (< (length args) 2)
 126             (equal? (car args) "-h")
 127             (equal? (car args) "--help"))
 128         (print "Usage:\n"
 129                progname " -h/--help\n"
 130                progname " gopher-root-dir server-hostname server-port")
 131         (let ((root (car args))
 132               (hostname (cadr args))
 133               (port (if (= (length args) 3) (string->number (caddr args)) 70)))
 134           (if port
 135               (run-server (make-server-config root hostname port))
 136               (error "Invalid port argument." port))))))
 137
 138 (main)
 139
 140 ;; (define (test)
 141   ;; (run-server (make-server-config "gopher-root" "localhost" 70)))
 142
 143 ;; (test)