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 "?") 7)
89 ;;; Selector retrieval
91 (define (serve-selector raw-selector remote-ip 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 remote-ip 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 remote-ip config)
148 (let ((file-name (make-pathname (config-root-dir config)
149 (conc (string-chomp selector "?") ".scm"))))
150 (if (and (regular-file? file-name)
151 (= (length arguments) 1))
152 (with-input-from-file file-name
159 (list (car arguments) remote-ip)))))))
160 (error "Invalid query."))))
165 (define (serve-info-records string)
169 (for-each (lambda (char)
170 (print* (if (eq? char #\tab)
174 (print "\tfake\tfake\t1\r"))
175 (string-split string "\n" #t)))
177 (define (serve-record record dir-selector config)
179 (('shell command) (serve-shell-command command dir-selector config))
180 (('eval expression) (serve-expression expression dir-selector config))
181 (('url display-string url)
182 (print #\h display-string "\tURL:" url "\tfake\t80\r"))
183 ((type display-string selector host port)
184 (print type display-string "\t" selector "\t" host "\t" port "\r"))
185 ((type display-string selector host)
186 (serve-record (list type display-string selector host 70)
187 dir-selector config))
188 ((type display-string selector)
189 (serve-record (list type display-string
190 (make-pathname dir-selector selector)
191 (config-host config) (config-port config))
192 dir-selector config))
193 ((display-string selector)
194 (serve-record (list (infer-selector-type selector) display-string selector)
195 dir-selector config))
197 (serve-record (list (infer-selecto-type selector) selector)
198 dir-selector config))
199 (else (error "Unknown record type."))))
201 (define (serve-shell-command command dir-selector config)
205 (let-values (((in-port out-port id) (process command)))
206 (serve-info-records (string-chomp (read-string #f in-port) "\n"))))))
208 (define (serve-expression expression dir-selector config)
212 (serve-info-records (conc (eval expression))))))
217 (define (with-current-working-directory directory thunk)
218 (let ((old-wd (current-directory))
220 (change-directory directory)
221 (set! result (thunk))
222 (change-directory old-wd)
225 (define (with-selector-dir selector config thunk)
226 (with-current-working-directory
227 (make-pathname (config-root-dir config)
228 (pathname-directory selector)) thunk))
232 (define (print-usage progname)
234 progname " -h/--help\n"
235 progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n"
237 "The -n option tells the server to not display a directory footer."))
240 (let* ((progname (car (argv)))
242 (config (make-config '() '() 70 #t)))
245 (equal? (car args) "-h")
246 (equal? (car args) "--help"))
247 (print-usage progname)
249 (if (or (equal? (car args) "-n")
250 (equal? (car args) "--no-footer"))
252 (config-display-footer-set! config #f)
253 (set! args (cdr args))))
254 (if (or (< (length args) 2)
256 (print-usage progname)
258 (config-root-dir-set! config (car args))
259 (config-host-set! config (cadr args))
260 (if (= (length args) 3)
261 (config-port-set! config (string->number (caddr args))))
262 (run-server config)))))))
267 ;; (run-server (make-config "gopher-root" "localhost" 70 #t)))