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!"))
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 (print "Gopher server listening on port " (config-port config) " ...")
43 (let ((listener (tcp-listen (config-port config))))
45 (let-values (((in-port out-port) (tcp-accept listener)))
46 (let* ((line (read-line in-port))
47 (selector (string-trim-both line)))
48 (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
49 (print "Accepted connection from " remote-ip
50 " on " (seconds->string))
53 (with-output-to-port out-port
55 (serve-selector (if (= (string-length selector) 0)
59 (print "... served selector '" selector "'. Closing connection."))
61 (print-error-message o out-port)
62 (print-error-message o)
63 (print "Error while attempting to serve selector " selector ".")))))
64 (close-input-port in-port)
65 (close-output-port out-port))
67 (tcp-close listener)))
70 ;;; Selector type inference
72 (define (has-suffix? selector . suffixes)
75 (if (string-suffix? (car suffixes) selector)
77 (apply has-suffix? selector (cdr suffixes)))))
79 (define (infer-selector-type selector)
80 (let ((l (string-downcase selector)))
82 ((or (= (string-length l) 0) (string-suffix? "/" l)) 1)
83 ((has-suffix? l ".txt" ".org" ".md") 0)
84 ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I)
85 ((has-suffix? l "?.scm") 7)
89 ;;; Selector retrieval
91 (define (serve-selector raw-selector config)
92 (let* ((selector-list (string-split raw-selector "\t"))
93 (selector (car selector-list))
94 (arguments (cdr selector-list)))
95 (case (infer-selector-type selector)
96 ((1) (serve-directory selector config))
97 ((0) (serve-text-file selector config))
98 ((7) (serve-query selector arguments config))
99 (else (serve-binary-file selector config)))))
101 (define (serve-directory selector config)
102 (let ((file-name (make-pathname (list (config-root-dir config) selector)
103 gopher-index-file-name)))
104 (if (regular-file? file-name)
106 (with-input-from-file file-name
108 (let loop ((c (peek-char)))
115 (serve-record (read) selector config)
117 (serve-info-records (read-line)))
118 (loop (peek-char)))))))
119 (if (config-display-footer config)
120 (serve-info-records burrower-footer)))
121 (error "Index file not found."))))
123 (define (serve-text-file selector config)
124 (let ((file-name (make-pathname (config-root-dir config) selector)))
125 (if (regular-file? file-name)
126 (with-input-from-file file-name
132 (error "File not found." file-name))))
134 (define (serve-binary-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
139 (let loop ((b (read-byte)))
144 (loop (read-byte)))))))
145 (error "File not found." file-name))))
147 (define (serve-query selector arguments config)
148 (let ((file-name (make-pathname (config-root-dir config) selector)))
149 (if (and (regular-file? file-name)
150 (= (length arguments) 1))
151 (with-input-from-file file-name
157 (apply (eval (read)) arguments))))))
158 (error "Invalid query." selector arguments))))
163 (define (serve-info-records string)
167 (for-each (lambda (char)
168 (print* (if (eq? char #\tab)
172 (print "\tfake\tfake\t1\r"))
173 (string-split string "\n" #t)))
175 (define (serve-record record dir-selector config)
177 (('shell command) (serve-shell-command command dir-selector config))
178 (('eval expression) (serve-expression expression dir-selector config))
179 (('url display-string url)
180 (print #\h display-string "\tURL:" url "\tfake\t80\r"))
181 ((type display-string selector host port)
182 (print type display-string "\t" selector "\t" host "\t" port "\r"))
183 ((type display-string selector host)
184 (serve-record (list type display-string selector host 70)
185 dir-selector config))
186 ((type display-string selector)
187 (serve-record (list type display-string
188 (make-pathname dir-selector selector)
189 (config-host config) (config-port config))
190 dir-selector config))
191 ((display-string selector)
192 (serve-record (list (infer-selector-type selector) display-string selector)
193 dir-selector config))
195 (serve-record (list (infer-selecto-type selector) selector)
196 dir-selector config))
197 (else (error "Unknown record type."))))
199 (define (serve-shell-command command dir-selector config)
203 (let-values (((in-port out-port id) (process command)))
204 (let ((string (read-string #f in-port)))
205 (if (and (not (eof-object? string))
206 (> (string-length string) 0))
207 (serve-info-records (string-chomp string "\n"))))))))
209 (define (serve-expression expression dir-selector config)
213 (serve-info-records (conc (eval expression))))))
218 (define (with-current-working-directory directory thunk)
219 (let ((old-wd (current-directory))
223 (change-directory directory)
224 (set! result (thunk))
225 (change-directory old-wd)
228 (change-directory old-wd)
231 (define (with-selector-dir selector config thunk)
232 (with-current-working-directory
233 (make-pathname (config-root-dir config)
234 (pathname-directory selector)) thunk))
238 (define (print-usage progname)
240 progname " -h/--help\n"
241 progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n"
243 "The -n option tells the server to not display a directory footer."))
246 (let* ((progname (car (argv)))
248 (config (make-config '() '() 70 #t)))
251 (equal? (car args) "-h")
252 (equal? (car args) "--help"))
253 (print-usage progname)
255 (if (or (equal? (car args) "-n")
256 (equal? (car args) "--no-footer"))
258 (config-display-footer-set! config #f)
259 (set! args (cdr args))))
260 (if (or (< (length args) 2)
262 (print-usage progname)
264 (config-root-dir-set! config (car args))
265 (config-host-set! config (cadr args))
266 (if (= (length args) 3)
267 (config-port-set! config (string->number (caddr args))))
268 (run-server config)))))))
273 ;; (run-server (make-config "gopher-root" "localhost" 70 #t)))