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

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

update gopher/phricken with licensing

File size: 4.6 KB
Line 
1;;; gopher chicken extension
2
3;; Copyright(c) 2009 Jim Ursetto.  All rights reserved.
4;; See EOF for license.
5
6;; API notes: send-* are specified to return a true value.
7
8(module gopher
9  (accept send-line send-lastline send-text-file send-binary-file 
10   make-entry send-entry entry? eol entry->string max-line-length)
11 
12  (import scheme chicken)
13  (require-library sendfile extras data-structures)
14  (import (only sendfile sendfile)
15          (only extras sprintf fprintf read-line)
16          (only data-structures string-translate string-split ->string))
17  (require-extension posix)
18
19  (define-record entry type name selector host port)
20  (define-record-printer (entry e p) ; Interacts badly with modules w/o my patch
21    (fprintf p "#<gopher-entry: ~A ~S ~S ~S ~A>"
22             (entry-type e) (entry-name e)
23             (entry-selector e) (entry-host e)
24             (entry-port e)))
25  (define (sanitize-selector str)
26    ;; Replace CR, LF, TAB and NUL.  Perhaps more?
27    (string-translate str "\r\n\t\x00" #\space))
28 
29  ;; Read a line from the client, split it into tabs and
30  ;; pass it into handle-request.  Meaning of fields after
31  ;; the selector is context-sensitive (ugh), so we pass
32  ;; those as a list.
33  ;; NB Official selector limit is 255 characters; we just
34  ;; limit the total input line length.
35  (define max-line-length (make-parameter 2048))
36  (define (accept handle-request)
37    (let ((line (read-line (current-input-port) (max-line-length))))
38      (and (not (eof-object? line))
39           (let ((fields (map sanitize-selector (string-split line "\t" #t))))
40             (handle-request (car fields) (cdr fields))))))
41
42  (define eol "\r\n")
43  (define (send-line line)
44    (display line)
45    (display eol)
46    #t)
47  (define (send-lastline)
48    (send-line ".")
49    (flush-output))
50
51  (define (send-text-file filename)
52    (let ((in (open-input-file filename)))
53      (handle-exceptions exn (begin (close-input-port in) (signal exn))
54        (let loop ()
55          (let ((line (read-line in)))
56            (cond ((eof-object? line)
57                   (send-lastline))
58                  (else
59                   (and (> (string-length line) 0)
60                        (char=? (string-ref line 0) #\.)
61                        (display #\.))
62                   (send-line line)
63                   (loop))))))
64      (close-input-port in)
65      #t))
66
67  (define (send-binary-file filename)
68    (let ((out (current-output-port)))
69      (let ((in (file-open filename (+ open/binary open/rdonly))))
70        (handle-exceptions exn (begin (file-close in) (signal exn))
71          ;; Contrary to doc, sendfile doesn't accept a port, due to FILE-SIZE.
72          (sendfile in out))
73        (file-close in)
74        #t)))
75
76  (define (entry->string e)
77    (define (s x)
78      (sanitize-selector (->string x)))
79    (sprintf "~a~a\t~a\t~a\t~a"
80                        (string-ref (s (entry-type e)) 0)
81                        (s (entry-name e))
82                        (s (entry-selector e))
83                        (s (entry-host e)) (s (entry-port e))))
84
85  (define (send-entry e)
86    (send-line (entry->string e)))
87  )
88
89;; Copyright (c) 2009 Jim Ursetto.  All rights reserved.
90;;
91;; Redistribution and use in source and binary forms, with or without
92;; modification, are permitted provided that the following conditions are met:
93;;
94;;  Redistributions of source code must retain the above copyright notice,
95;;   this list of conditions and the following disclaimer.
96;;  Redistributions in binary form must reproduce the above copyright notice,
97;;   this list of conditions and the following disclaimer in the documentation
98;;   and/or other materials provided with the distribution.
99;;  Neither the name of the author nor the names of its contributors
100;;   may be used to endorse or promote products derived from this software
101;;   without specific prior written permission.
102;;
103;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
104;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
105;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
106;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
107;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
108;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
109;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
110;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
111;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
112;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
113;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Note: See TracBrowser for help on using the repository browser.