62aa85329022acef87cbe34a03bef93f2af2f18c
[scratchy.git] / burrower.scm
1 ;;; Imports
2
3 ;; Chicken 5
4 (import (chicken tcp)
5         (chicken port)
6         (chicken io)
7         (chicken string)
8         (chicken pathname)
9         (chicken file posix)
10         (chicken time posix)
11         (chicken condition)
12         (chicken process)
13         (chicken process-context)
14         srfi-1 srfi-13 matchable)
15
16 ;; Chicken 4
17 ;; (use srfi-1 srfi-13 tcp posix matchable)
18
19 ;;; Global constants
20
21 (define gopher-index-filename "index")
22
23 (define burrower-version "1.0.0")
24
25 (define burrower-footer
26   (conc "\n"
27         "--------------------------------------------------\n"
28         "This gopher hole was dug using Burrower v" burrower-version "\n"
29         "Powered by Chicken Scheme!"))
30
31 ;;; Server loop
32
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. :-(
37
38 (define-record config root-dir host port display-footer)
39
40 (define (run-server config)
41   (print "Gopher server listening on port " (config-port config) " ...")
42   (let ((listener (tcp-listen (config-port config))))
43     (let server-loop ()
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))
50             (condition-case
51                 (begin
52                   (with-output-to-port out-port
53                     (lambda ()
54                       (serve-selector (if (= (string-length selector) 0)
55                                           "/"
56                                           selector)
57                                       config)))
58                   (print "... served selector '" selector "'. Closing connection."))
59               (o (exn)
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))
65       (server-loop))
66     (tcp-close listener)))
67
68
69 ;;; Selector type inference
70
71 (define (true-for-one? predicate values)
72   (if (null? values)
73       #f
74       (if (predicate (car values))
75           #t
76           (true-for-one? predicate (cdr values)))))
77
78 (define (has-suffix? selector . suffixes)
79   (true-for-one? (lambda (suffix)
80                    (string-suffix? suffix selector))
81                  suffixes))
82
83 (define (has-prefix? selector . prefixes)
84   (true-for-one? (lambda (prefix)
85                    (string-prefix? prefix selector))
86                  prefixes))
87
88 (define (infer-selector-type selector)
89   (let ((l (string-downcase selector)))
90     (cond
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)
96      (else 9))))
97
98
99 ;;; Selector retrieval
100
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)))))
111
112 (define (legal-filename? filename config)
113   (and (string-prefix? (config-root-dir config)
114                        (normalize-pathname filename))
115        (regular-file? filename)))
116
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)
121         (begin
122           (with-input-from-file filename
123             (lambda ()
124               (let loop ((c (peek-char)))
125                 (if (eof-object? c)
126                     'done
127                     (begin
128                       (if (eq? c #\,)
129                           (begin
130                             (read-char)
131                             (serve-record (read) selector config)
132                             (read-line))
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."))))
138   
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
143           (lambda ()
144             (for-each
145              (lambda (line)
146                (print line "\r"))
147              (read-lines))))
148         (error "File not found." filename))))
149
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
154           (lambda ()
155             (let loop ((b (read-byte)))
156               (if (eof-object? b)
157                   'done
158                   (begin
159                     (write-byte b)
160                     (loop (read-byte)))))))
161         (error "File not found." filename))))
162
163 (define (serve-query selector arguments config)
164   (let ((filename (make-pathname (config-root-dir config) selector)))
165     (if (and (legal-filename? filename config)
166              (= (length arguments) 1))
167         (with-input-from-file filename
168           (lambda ()
169             (serve-info-records
170              (with-selector-dir
171               selector config
172               (lambda ()
173                 (apply (eval (read)) arguments))))))
174         (error "Invalid query." selector arguments))))
175
176
177 (define (serve-url selector config)
178   (let ((url (substring selector 4)))
179     (print
180      "If you are seeing this page, your gopher browser does not\r\n"
181      "properly support URL directory entries or cannot follow such\r\n"
182      "links.  To view the link you requested, use a web browser to\r\n"
183      "open the follwing url:\r\n"
184      "\r\n"
185      url "\r\n")))
186
187
188 ;;; Index rendering
189
190 (define (serve-info-records string)
191   (for-each
192    (lambda (line)
193      (print* "i")
194      (for-each (lambda (char)
195                  (print* (if (eq? char #\tab)
196                              "    "
197                              char)))
198                (string->list line))
199      (print "\tfake\tfake\t1\r"))
200    (string-split string "\n" #t)))
201
202 (define (serve-record record dir-selector config)
203   (match record
204     (('shell command) (serve-shell-command command dir-selector config))
205     (('eval expression) (serve-expression expression dir-selector config))
206     (('url display-string url)
207      (print #\h display-string "\tURL:" url
208             "\t" (config-host config)
209             "\t" (config-port config) "\r"))
210     ((type display-string selector host port)
211      (print type display-string "\t" selector "\t" host "\t" port "\r"))
212     ((type display-string selector host)
213      (serve-record (list type display-string selector host 70)
214                    dir-selector config))
215     ((type display-string selector)
216      (serve-record (list type display-string
217                          (make-pathname dir-selector selector)
218                          (config-host config) (config-port config))
219                    dir-selector config))
220     ((display-string selector)
221      (serve-record (list (infer-selector-type selector) display-string selector)
222                    dir-selector config))
223     ((selector)
224      (serve-record (list (infer-selecto-type selector) selector)
225                    dir-selector config))
226     (else (error "Unknown record type."))))
227
228 (define (serve-shell-command command dir-selector config)
229   (with-selector-dir
230    dir-selector config
231    (lambda ()
232      (let-values (((in-port out-port id) (process command)))
233        (let ((string (read-string #f in-port)))
234          (if (and (not (eof-object? string))
235                   (> (string-length string) 0))
236              (serve-info-records (string-chomp string "\n"))))))))
237
238 (define (serve-expression expression dir-selector config)
239   (with-selector-dir
240    dir-selector config
241    (lambda ()
242      (serve-info-records (conc (eval expression))))))
243
244
245 ;;; Utility methods
246
247 (define (with-current-working-directory directory thunk)
248   (let ((old-wd (current-directory))
249         (result 'none))
250     (condition-case
251         (begin
252           (change-directory directory)
253           (set! result (thunk))
254           (change-directory old-wd)
255           result)
256       (o (exn)
257          (change-directory old-wd)
258          (signal o)))))
259
260 (define (with-selector-dir selector config thunk)
261   (with-current-working-directory
262    (make-pathname (config-root-dir config)
263                   (pathname-directory selector)) thunk))
264
265 ;;; main
266
267 (define (print-usage progname)
268   (print "Usage:\n"
269          progname " -h/--help\n"
270          progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n"
271          "\n"
272          "The -n option tells the server to not display a directory footer."))
273
274 (define (main)
275   (let* ((progname (car (argv)))
276          (args (cdr (argv)))
277          (config (make-config '() '() 70 #t)))
278
279     (if (or (null? args)
280             (equal? (car args) "-h")
281             (equal? (car args) "--help"))
282         (print-usage progname)
283         (begin
284           (if (or (equal? (car args) "-n")
285                   (equal? (car args) "--no-footer"))
286               (begin
287                 (config-display-footer-set! config #f)
288                 (set! args (cdr args))))
289           (if (or (< (length args) 2)
290                   (> (length args) 3))
291               (print-usage progname)
292               (begin
293                 (config-root-dir-set! config (car args))
294                 (config-host-set! config (cadr args))
295                 (if (= (length args) 3)
296                     (config-port-set! config (string->number (caddr args))))
297                 (run-server config)))))))
298
299 (main)
300
301 ;; (define (test)
302 ;;   (run-server (make-config "gopher-root" "localhost" 70 #t)))
303
304 ;; (test)