source: project/release/4/gopher/trunk/gopher.scm @ 13273

Last change on this file since 13273 was 13273, checked in by Jim Ursetto, 12 years ago

gopher: add max-line-length

File size: 2.9 KB
Line 
1;; API notes: send-* are specified to return a true value.
2
3(module gopher
4  (accept send-line send-lastline send-text-file send-binary-file 
5   make-entry send-entry entry? eol entry->string max-line-length)
6 
7  (import scheme chicken)
8  (require-library sendfile extras data-structures)
9  (import (only sendfile sendfile)
10          (only extras sprintf fprintf read-line)
11          (only data-structures string-translate string-split ->string))
12  (require-extension posix)
13
14  (define-record entry type name selector host port)
15  (define-record-printer (entry e p) ; Interacts badly with modules w/o my patch
16    (fprintf p "#<gopher-entry: ~A ~S ~S ~S ~A>"
17             (entry-type e) (entry-name e)
18             (entry-selector e) (entry-host e)
19             (entry-port e)))
20  (define (sanitize-selector str)
21    ;; Replace CR, LF, TAB and NUL.  Perhaps more?
22    (string-translate str "\r\n\t\x00" #\space))
23 
24  ;; Read a line from the client, split it into tabs and
25  ;; pass it into handle-request.  Meaning of fields after
26  ;; the selector is context-sensitive (ugh), so we pass
27  ;; those as a list.
28  ;; NB Official selector limit is 255 characters; we just
29  ;; limit the total input line length.
30  (define max-line-length (make-parameter 2048))
31  (define (accept handle-request)
32    (let ((line (read-line (current-input-port) (max-line-length))))
33      (and (not (eof-object? line))
34           (let ((fields (map sanitize-selector (string-split line "\t" #t))))
35             (handle-request (car fields) (cdr fields))))))
36
37  (define eol "\r\n")
38  (define (send-line line)
39    (display line)
40    (display eol)
41    #t)
42  (define (send-lastline)
43    (send-line ".")
44    (flush-output))
45
46  (define (send-text-file filename)
47    (let ((in (open-input-file filename)))
48      (handle-exceptions exn (begin (close-input-port in) (signal exn))
49        (let loop ()
50          (let ((line (read-line in)))
51            (cond ((eof-object? line)
52                   (send-lastline))
53                  (else
54                   (and (> (string-length line) 0)
55                        (char=? (string-ref line 0) #\.)
56                        (display #\.))
57                   (send-line line)
58                   (loop))))))
59      (close-input-port in)
60      #t))
61
62  (define (send-binary-file filename)
63    (let ((out (current-output-port)))
64      (let ((in (file-open filename (+ open/binary open/rdonly))))
65        (handle-exceptions exn (begin (file-close in) (signal exn))
66          ;; Contrary to doc, sendfile doesn't accept a port, due to FILE-SIZE.
67          (sendfile in out))
68        (file-close in)
69        #t)))
70
71  (define (entry->string e)
72    (define (s x)
73      (sanitize-selector (->string x)))
74    (sprintf "~a~a\t~a\t~a\t~a"
75                        (string-ref (s (entry-type e)) 0)
76                        (s (entry-name e))
77                        (s (entry-selector e))
78                        (s (entry-host e)) (s (entry-port e))))
79
80  (define (send-entry e)
81    (send-line (entry->string e)))
82  )
Note: See TracBrowser for help on using the repository browser.