13 (chicken process-context)
14 srfi-1 srfi-13 matchable)
17 ;; (use srfi-1 srfi-13 tcp posix matchable)
21 (define gopher-index-filename "index")
23 (define burrower-version "1.0.0")
25 (define burrower-footer
27 "--------------------------------------------------\n"
28 "This gopher hole was dug using Burrower v" burrower-version "\n"
29 "Powered by Chicken Scheme!"))
33 ;; We don't yet use worker threads here to handle requests,
34 ;; the server just blocks until the first request is finished.
35 ;; While we should fix this, it's actually probably okay, as
36 ;; we genuinely don't expect a huge flood of gopher traffic. :-(
38 (define-record config root-dir host port display-footer)
40 (define (run-server config)
41 (print "Gopher server listening on port " (config-port config) " ...")
42 (let ((listener (tcp-listen (config-port config))))
44 (let-values (((in-port out-port) (tcp-accept listener)))
45 (let* ((line (read-line in-port))
46 (selector (string-trim-both line)))
47 (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
48 (print "Accepted connection from " remote-ip
49 " on " (seconds->string))
52 (with-output-to-port out-port
54 (serve-selector (if (= (string-length selector) 0)
58 (print "... served selector '" selector "'. Closing connection."))
60 (print-error-message o out-port)
61 (print-error-message o)
62 (print "Error while attempting to serve selector " selector ".")))))
63 (close-input-port in-port)
64 (close-output-port out-port))
66 (tcp-close listener)))
69 ;;; Selector type inference
71 (define (true-for-one? predicate values)
74 (if (predicate (car values))
76 (true-for-one? predicate (cdr values)))))
78 (define (has-suffix? selector . suffixes)
79 (true-for-one? (lambda (suffix)
80 (string-suffix? suffix selector))
83 (define (has-prefix? selector . prefixes)
84 (true-for-one? (lambda (prefix)
85 (string-prefix? prefix selector))
88 (define (infer-selector-type selector)
89 (let ((l (string-downcase selector)))
91 ((or (= (string-length l) 0) (string-suffix? "/" l)) 1)
92 ((has-suffix? l ".txt" ".org" ".md") 0)
93 ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I)
94 ((has-suffix? l "?.scm" "%3f.scm") 7)
95 ((has-prefix? l "url:" "/url:") 'h)
99 ;;; Selector retrieval
101 (define (serve-selector raw-selector config)
102 (let* ((selector-list (string-split raw-selector "\t"))
103 (selector (car selector-list))
104 (arguments (cdr selector-list)))
105 (case (infer-selector-type selector)
106 ((1) (serve-directory selector config))
107 ((0) (serve-text-file selector config))
108 ((7) (serve-query selector arguments config))
109 ((h) (serve-url selector config))
110 (else (serve-binary-file selector config)))))
112 (define (legal-filename? filename config)
113 (and (string-prefix? (config-root-dir config)
114 (normalize-pathname filename))
115 (regular-file? filename)))
117 (define (serve-directory selector config)
118 (let ((filename (make-pathname (list (config-root-dir config) selector)
119 gopher-index-filename)))
120 (if (legal-filename? filename config)
122 (with-input-from-file filename
124 (let loop ((c (peek-char)))
131 (serve-record (read) selector config)
133 (serve-info-records (read-line)))
134 (loop (peek-char)))))))
135 (if (config-display-footer config)
136 (serve-info-records burrower-footer)))
137 (error "Index file not found."))))
139 (define (serve-text-file selector config)
140 (let ((filename (make-pathname (config-root-dir config) selector)))
141 (if (legal-filename? filename config)
142 (with-input-from-file filename
148 (error "File not found." filename))))
150 (define (serve-binary-file selector config)
151 (let ((filename (make-pathname (config-root-dir config) selector)))
152 (if (legal-filename? filename config)
153 (with-input-from-file filename
155 (let loop ((b (read-byte)))
160 (loop (read-byte)))))))
161 (error "File not found." filename))))
163 (define (serve-query selector arguments config)
164 (let ((filename (make-pathname (config-root-dir config)
165 (string-translate* selector '(("%3f" . "?"))))))
166 (if (and (legal-filename? filename config)
167 (= (length arguments) 1))
168 (with-input-from-file filename
174 (apply (eval (read)) arguments))))))
175 (error "Invalid query." selector arguments))))
178 (define (serve-url selector config)
179 (let ((url (substring selector 4)))
181 "<html><head><title>Redirection</title>"
182 "<meta http-equiv=\"refresh\" content=\"10; URL='" url "'\" />"
184 "<p>If you are seeing this page, your gopher browser does not "
185 "properly support URL directory entries or cannot follow such "
187 "<p>If you are viewing this page using a web browser, you should "
188 "be redirected shortly. Otherwise, you can manually open the "
189 "the follwing url:\n"
191 "<a href=\"" url "\">" url "</a>\n"
197 (define (serve-info-records string)
201 (for-each (lambda (char)
202 (print* (if (eq? char #\tab)
206 (print "\tfake\tfake\t1\r"))
207 (string-split string "\n" #t)))
209 (define (serve-record record dir-selector config)
211 (('shell command) (serve-shell-command command dir-selector config))
212 (('eval expression) (serve-expression expression dir-selector config))
213 (('url display-string url)
214 (print #\h display-string "\tURL:" url
215 "\t" (config-host config)
216 "\t" (config-port config) "\r"))
217 ((type display-string selector host port)
218 (print type display-string "\t" selector "\t" host "\t" port "\r"))
219 ((type display-string selector host)
220 (serve-record (list type display-string selector host 70)
221 dir-selector config))
222 ((type display-string selector)
223 (serve-record (list type display-string
224 (make-pathname dir-selector selector)
225 (config-host config) (config-port config))
226 dir-selector config))
227 ((display-string selector)
228 (serve-record (list (infer-selector-type selector) display-string selector)
229 dir-selector config))
231 (serve-record (list (infer-selecto-type selector) selector)
232 dir-selector config))
233 (else (error "Unknown record type."))))
235 (define (serve-shell-command command dir-selector config)
239 (let-values (((in-port out-port id) (process command)))
240 (let ((string (read-string #f in-port)))
241 (if (and (not (eof-object? string))
242 (> (string-length string) 0))
243 (serve-info-records (string-chomp string "\n"))))))))
245 (define (serve-expression expression dir-selector config)
249 (serve-info-records (conc (eval expression))))))
254 (define (with-current-working-directory directory thunk)
255 (let ((old-wd (current-directory))
259 (change-directory directory)
260 (set! result (thunk))
261 (change-directory old-wd)
264 (change-directory old-wd)
267 (define (with-selector-dir selector config thunk)
268 (with-current-working-directory
269 (make-pathname (config-root-dir config)
270 (pathname-directory selector)) thunk))
274 (define (print-usage progname)
276 progname " -h/--help\n"
277 progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n"
279 "The -n option tells the server to not display a directory footer."))
282 (let* ((progname (car (argv)))
284 (config (make-config '() '() 70 #t)))
287 (equal? (car args) "-h")
288 (equal? (car args) "--help"))
289 (print-usage progname)
291 (if (or (equal? (car args) "-n")
292 (equal? (car args) "--no-footer"))
294 (config-display-footer-set! config #f)
295 (set! args (cdr args))))
296 (if (or (< (length args) 2)
298 (print-usage progname)
300 (config-root-dir-set! config (car args))
301 (config-host-set! config (cadr args))
302 (if (= (length args) 3)
303 (config-port-set! config (string->number (caddr args))))
304 (run-server config)))))))
309 ;; (run-server (make-config "gopher-root" "localhost" 70 #t)))