13 (chicken process-context)
14 srfi-1 srfi-13 matchable)
17 ;; (use srfi-1 srfi-13 tcp posix matchable)
21 (define gopher-index-file-name "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") 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 (serve-directory selector config)
113 (let ((file-name (make-pathname (list (config-root-dir config) selector)
114 gopher-index-file-name)))
115 (if (regular-file? file-name)
117 (with-input-from-file file-name
119 (let loop ((c (peek-char)))
126 (serve-record (read) selector config)
128 (serve-info-records (read-line)))
129 (loop (peek-char)))))))
130 (if (config-display-footer config)
131 (serve-info-records burrower-footer)))
132 (error "Index file not found."))))
134 (define (serve-text-file selector config)
135 (let ((file-name (make-pathname (config-root-dir config) selector)))
136 (if (regular-file? file-name)
137 (with-input-from-file file-name
143 (error "File not found." file-name))))
145 (define (serve-binary-file selector config)
146 (let ((file-name (make-pathname (config-root-dir config) selector)))
147 (if (regular-file? file-name)
148 (with-input-from-file file-name
150 (let loop ((b (read-byte)))
155 (loop (read-byte)))))))
156 (error "File not found." file-name))))
158 (define (serve-query selector arguments config)
159 (let ((file-name (make-pathname (config-root-dir config) selector)))
160 (if (and (regular-file? file-name)
161 (= (length arguments) 1))
162 (with-input-from-file file-name
168 (apply (eval (read)) arguments))))))
169 (error "Invalid query." selector arguments))))
172 (define (serve-url selector config)
173 (let ((url (substring selector 4)))
175 "If you are seeing this page, your gopher browser does not\r\n"
176 "properly support URL directory entries or cannot follow such\r\n"
177 "links. To view the link you requested, use a web browser to\r\n"
178 "open the follwing url:\r\n"
185 (define (serve-info-records string)
189 (for-each (lambda (char)
190 (print* (if (eq? char #\tab)
194 (print "\tfake\tfake\t1\r"))
195 (string-split string "\n" #t)))
197 (define (serve-record record dir-selector config)
199 (('shell command) (serve-shell-command command dir-selector config))
200 (('eval expression) (serve-expression expression dir-selector config))
201 (('url display-string url)
202 (print #\h display-string "\tURL:" url
203 "\t" (config-host config)
204 "\t" (config-port config) "\r"))
205 ((type display-string selector host port)
206 (print type display-string "\t" selector "\t" host "\t" port "\r"))
207 ((type display-string selector host)
208 (serve-record (list type display-string selector host 70)
209 dir-selector config))
210 ((type display-string selector)
211 (serve-record (list type display-string
212 (make-pathname dir-selector selector)
213 (config-host config) (config-port config))
214 dir-selector config))
215 ((display-string selector)
216 (serve-record (list (infer-selector-type selector) display-string selector)
217 dir-selector config))
219 (serve-record (list (infer-selecto-type selector) selector)
220 dir-selector config))
221 (else (error "Unknown record type."))))
223 (define (serve-shell-command command dir-selector config)
227 (let-values (((in-port out-port id) (process command)))
228 (let ((string (read-string #f in-port)))
229 (if (and (not (eof-object? string))
230 (> (string-length string) 0))
231 (serve-info-records (string-chomp string "\n"))))))))
233 (define (serve-expression expression dir-selector config)
237 (serve-info-records (conc (eval expression))))))
242 (define (with-current-working-directory directory thunk)
243 (let ((old-wd (current-directory))
247 (change-directory directory)
248 (set! result (thunk))
249 (change-directory old-wd)
252 (change-directory old-wd)
255 (define (with-selector-dir selector config thunk)
256 (with-current-working-directory
257 (make-pathname (config-root-dir config)
258 (pathname-directory selector)) thunk))
262 (define (print-usage progname)
264 progname " -h/--help\n"
265 progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n"
267 "The -n option tells the server to not display a directory footer."))
270 (let* ((progname (car (argv)))
272 (config (make-config '() '() 70 #t)))
275 (equal? (car args) "-h")
276 (equal? (car args) "--help"))
277 (print-usage progname)
279 (if (or (equal? (car args) "-n")
280 (equal? (car args) "--no-footer"))
282 (config-display-footer-set! config #f)
283 (set! args (cdr args))))
284 (if (or (< (length args) 2)
286 (print-usage progname)
288 (config-root-dir-set! config (car args))
289 (config-host-set! config (cadr args))
290 (if (= (length args) 3)
291 (config-port-set! config (string->number (caddr args))))
292 (run-server config)))))))
297 ;; (run-server (make-config "gopher-root" "localhost" 70 #t)))