1 ;;; Burrower gopher server
3 ;; Requires Chicken 5.0.0.
17 (chicken process-context)
18 srfi-1 srfi-13 matchable)
22 (define gopher-index-filename "index")
24 (define burrower-version "1.0.0")
26 (define burrower-footer
28 "--------------------------------------------------\n"
29 "This gopher hole was dug using Burrower v" burrower-version ".\n"
30 "Powered by Chicken Scheme!"))
34 ;; We don't yet use worker threads here to handle requests,
35 ;; the server just blocks until the first request is finished.
36 ;; While we should fix this, it's actually probably okay, as
37 ;; we genuinely don't expect a huge flood of gopher traffic. :-(
39 (define-record config root-dir host port display-footer)
41 (define (run-server config)
42 (set-buffering-mode! (current-output-port) #:line)
43 (print "Gopher server listening on port " (config-port config) " ...")
44 (let ((listener (tcp-listen (config-port config))))
46 (let-values (((in-port out-port) (tcp-accept listener)))
47 (let* ((line (read-line in-port))
48 (selector (string-trim-both line)))
49 (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
50 (print "Accepted connection from " remote-ip
51 " on " (seconds->string))
54 (with-output-to-port out-port
56 (serve-selector (if (= (string-length selector) 0)
60 (print "... served selector '" selector "'. Closing connection."))
62 (print-error-message o out-port)
63 (print-error-message o)
64 (print "Error while attempting to serve selector " selector ".")))))
65 (close-input-port in-port)
66 (close-output-port out-port))
68 (tcp-close listener)))
71 ;;; Selector type inference
73 (define (true-for-one? predicate values)
76 (if (predicate (car values))
78 (true-for-one? predicate (cdr values)))))
80 (define (has-suffix? selector . suffixes)
81 (true-for-one? (lambda (suffix)
82 (string-suffix? suffix selector))
85 (define (has-prefix? selector . prefixes)
86 (true-for-one? (lambda (prefix)
87 (string-prefix? prefix selector))
90 (define (infer-selector-type selector)
91 (let ((l (string-downcase selector)))
93 ((or (= (string-length l) 0)
94 (string-suffix? "/" l)
95 (string-contains l ":")) 1)
96 ((has-suffix? l ".txt" ".org" ".md") 0)
97 ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I)
98 ((has-suffix? l "?" "%3f") 7)
99 ((has-prefix? l "url:" "/url:") 'h)
103 ;;; Selector retrieval
105 (define (serve-selector raw-selector config)
106 (let* ((selector-list (string-split raw-selector "\t"))
107 (selector (car selector-list))
108 (arguments (cdr selector-list)))
109 (if (string-contains selector ":")
110 (let ((l (string-split selector ":")))
111 (serve-script (car l) (cdr l) config))
112 (case (infer-selector-type selector)
113 ((1) (serve-directory-file selector config))
114 ((7) (let ((l (string-split selector "?")))
115 (serve-script (car l) arguments config)))
116 ((0) (serve-text-file selector config))
117 ((h) (serve-url selector config))
118 (else (serve-binary-file selector config))))))
120 (define (legal-filename? filename config)
121 (and (string-prefix? (config-root-dir config)
122 (normalize-pathname filename))
123 (file-exists? filename)
124 (not (directory-exists? filename))
125 (file-readable? filename)))
127 (define (legal-script-filename? filename config)
128 (and (legal-filename? filename config)
129 (string-suffix? ".scm" filename)
130 (file-executable? filename)))
132 (define (serve-directory-file selector config)
133 (let ((filename (make-pathname (list (config-root-dir config) selector)
134 gopher-index-filename)))
135 (if (legal-filename? filename config)
137 (with-input-from-file filename
139 (let loop ((c (peek-char)))
146 (serve-record (read) selector config)
148 (serve-info-records (read-line)))
149 (loop (peek-char)))))))
150 (if (config-display-footer config)
151 (serve-info-records burrower-footer))
153 (error "No legal index file not found."))))
155 (define (serve-text-file selector config)
156 (let ((filename (make-pathname (config-root-dir config) selector)))
157 (if (legal-filename? filename config)
159 (with-input-from-file filename
166 (error "File not found." filename))))
168 (define (serve-binary-file selector config)
169 (let ((filename (make-pathname (config-root-dir config) selector)))
170 (if (legal-filename? filename config)
171 (with-input-from-file filename
173 (let loop ((b (read-byte)))
178 (loop (read-byte)))))))
179 (error "File not found." filename))))
181 (define (serve-url selector config)
182 (let ((url (substring selector 4)))
184 "<html><head><title>Redirection</title>"
185 "<meta http-equiv=\"refresh\" content=\"10; URL='" url "'\" />"
187 "<p>If you are seeing this page, your gopher browser does not "
188 "properly support URL directory entries or cannot follow such "
190 "<p>If you are viewing this page using a web browser, you should "
191 "be redirected shortly. Otherwise, you can manually open the "
192 "the follwing url:\n"
194 "<a href=\"" url "\">" url "</a>\n"
197 (define (serve-script selector arguments config)
198 (let ((filename (make-pathname (config-root-dir config) selector)))
199 (if (legal-script-filename? filename config)
200 (let* ((sexp (with-input-from-file filename read))
201 (script-result (with-selector-dir
204 (apply (eval sexp) arguments)))))
205 (when (pair? script-result)
206 (serve-records script-result
207 (pathname-directory selector) config)
209 (error "No legal index script not found." filename))))
214 (define (serve-records records dir-selector config)
217 (serve-record record dir-selector config))
220 (define (serve-info-records string)
224 (for-each (lambda (char)
225 (print* (if (eq? char #\tab)
229 (print "\tfake\tfake\t1\r"))
230 (string-split string "\n" #t)))
232 (define (serve-record record dir-selector config)
234 ((? string?) (serve-info-records record))
235 (('shell command) (serve-shell-command command dir-selector config))
236 (('eval expression) (serve-expression expression dir-selector config))
237 (('url display-string url)
238 (print #\h display-string "\tURL:" url
239 "\t" (config-host config)
240 "\t" (config-port config) "\r"))
241 ((type display-string selector host port)
242 (print type display-string "\t" selector "\t" host "\t" port "\r"))
243 ((type display-string selector host)
244 (serve-record (list type display-string selector host 70)
245 dir-selector config))
246 ((type display-string selector)
247 (serve-record (list type display-string
248 (make-pathname dir-selector selector)
249 (config-host config) (config-port config))
250 dir-selector config))
251 ((display-string selector)
252 (serve-record (list (infer-selector-type selector) display-string selector)
253 dir-selector config))
255 (serve-record (list (infer-selector-type selector) selector)
256 dir-selector config))
257 (else (error "Unknown record type."))))
259 (define (serve-shell-command command dir-selector config)
263 (let-values (((in-port out-port id) (process command)))
264 (let ((string (read-string #f in-port)))
265 (if (and (not (eof-object? string))
266 (> (string-length string) 0))
267 (serve-info-records (string-chomp string "\n")))
268 (close-input-port in-port)
269 (close-output-port out-port))))))
271 (define (serve-expression expression dir-selector config)
275 (serve-records (eval expression) dir-selector config))))
280 (define (with-current-working-directory directory thunk)
281 (let ((old-wd (current-directory))
285 (change-directory directory)
286 (set! result (thunk))
287 (change-directory old-wd)
290 (change-directory old-wd)
293 (define (with-selector-dir selector config thunk)
294 (with-current-working-directory
295 (make-pathname (config-root-dir config)
296 (pathname-directory selector)) thunk))
301 (define (print-usage progname)
303 progname " -h/--help\n"
304 progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n"
306 "The -n option tells the server to not display a directory footer."))
309 (let* ((progname (car (argv)))
311 (config (make-config '() '() 70 #t)))
314 (equal? (car args) "-h")
315 (equal? (car args) "--help"))
316 (print-usage progname)
318 (if (or (equal? (car args) "-n")
319 (equal? (car args) "--no-footer"))
321 (config-display-footer-set! config #f)
322 (set! args (cdr args))))
323 (if (or (< (length args) 2)
325 (print-usage progname)
327 (config-root-dir-set! config (car args))
328 (config-host-set! config (cadr args))
329 (if (= (length args) 3)
330 (config-port-set! config (string->number (caddr args))))
331 (run-server config)))))))
336 ;; (run-server (make-config "gopher-root" "localhost" 70 #t)))