source: project/release/4/phricken/trunk/phricken.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: 15.6 KB
Line 
1
2;;; phricken chicken extension
3
4;; Copyright(c) 2009 Jim Ursetto.  All rights reserved.
5;; See EOF for license.
6
7(require-library gopher) ;; doesn't work inside module when not compiled
8
9(module phricken
10  (make-entry make-info-entry make-error-entry make-url-entry
11   sgm->entry send-entry send-entries
12   match-selector
13   ;; request object
14   request? request-selector request-matches request-extra
15   ;; utilities
16   sanitize-filename selector->filename utc-seconds->string
17   match-resource match-url bind-fs any-handler
18   start-server! filenames->entries extension-type
19   ;; handlers
20   handle-request handle-url handle-file handle-sgm handle-open-dir
21   handlers
22   ;; parameters
23   host port sgm-rules url-redirect-time
24   logger logger-port client-ip extension-type-map
25   path->entry
26   ;; reexports from gopher
27   send-lastline send-line
28   )
29
30(import scheme chicken)
31(require-library srfi-1 ports srfi-13 files)
32(import (prefix (only gopher make-entry send-entry entry? accept)
33                gopher:))
34(import (except gopher make-entry send-entry entry? accept))
35(import (only srfi-1 cons* any filter-map)
36        (only srfi-13 string-downcase)
37        (only files pathname-extension)
38        (only ports with-output-to-string))
39
40;; All this for URI encoding.  And uri-generic SVN head required!
41(require-library srfi-14 uri-generic)
42(import (only srfi-14 char-set-difference char-set-complement))
43(import (only uri-generic
44              uri-encode-string char-set:uri-unreserved char-set:gen-delims))
45
46(use srfi-18 extras data-structures)
47(use tcp-server tcp regex matchable posix)
48(import irregex)  ; weird
49
50;;; Parameters
51
52(define host (make-parameter (get-host-name)))
53(define port (make-parameter 70))
54(define client-ip (make-parameter #f))   ; Read-only for users.
55
56;;; Records
57
58(define-record request selector matches extra)
59
60;;; Logging
61
62;; Default is (current-error-port); it is set to this value
63;; at module init time, so won't be looked up dynamically.
64(define logger-port
65  (make-parameter (current-error-port))) ; set at init time!
66;; Convert seconds since UNIX epoch into string in format "yy-mm-dd HH:MM:SS".
67;; Seconds are interpreted as UTC time.
68(define (utc-seconds->string seconds)
69  (define (w2 x)
70    (if (< x 10) (sprintf "0~a" x) (sprintf "~a" x)))
71  (let ((v (seconds->utc-time seconds)))
72    (define (g x)
73      (vector-ref v x))
74    (conc
75     (+ (g 5) 1900) "-" (w2 (+ (g 4) 1)) "-" (w2 (g 3)) " " ; yyyy-mm-dd
76     (w2 (g 2)) ":" (w2 (g 1)) ":" (w2 (g 0)))))            ; HH:MM:SS
77;; Default logger implementation logs a formatted message to (logger-port),
78;; or skips logging if the port is #f.  No locking is performed.
79;; Seeking to end is performed prior to writing, but it is recommended
80;; the port be opened in #:append mode.
81;; It is legal for REQ to be #f if a request has not yet been created.
82;; TYPE can be any symbol; current types are 'connect, 'access,
83;; 'error, 'redirect.
84(define logger
85  (make-parameter
86   (lambda (type req . msg)
87     (when (logger-port)
88       (let ((sel (or (and req (request-selector req))
89                      '-))
90             (ip (or (client-ip) '-))
91             (p (logger-port)))
92         (set! (file-position p 0) seek/end)
93         (fprintf p         ; thread ID might be nice.
94                  "~A ~A:~A ~A ~A ~S ~A\n"
95                  (utc-seconds->string (current-seconds))
96                  (host) (port) ip
97                  type sel
98                  (apply conc msg))
99         (flush-output p))))))
100
101;;; Creating entries
102
103(define (make-entry type name sel #!optional (host (host)) (port (port)))
104  (gopher:make-entry type name sel host port))
105(define (make-info-entry . msg)
106  (make-entry "i" (apply conc msg) "fake" "(NULL)" 0))
107(define (make-error-entry . msg)
108  (make-entry "3" (apply conc msg) "fake" "(NULL)" 0))
109(define (make-url-entry name url)
110  (make-entry "h" name (string-append "URL:" url) (host) (port)))
111
112;;; Converting Scheme (S-expr) Gophermaps to entries
113
114;; sgm-rules: alist mapping entry type to a procedure which creates
115;; that entry.  Procedure is passed the current sgm entry via APPLY.
116(define sgm-rules
117  (make-parameter
118   `((*default* . ,make-entry)
119     (i . ,(lambda (type . msg)    (apply make-info-entry msg)))
120     (3 . ,(lambda (type . msg)    (apply make-error-entry msg)))
121     (h . ,(lambda (type name url) (make-url-entry name url)))
122)))
123
124;; Convert expr to entry using sgm-rules.  If entry type is not found,
125;; the rule *default* is consulted; an error is signaled if no rules match.
126(define (sgm->entry expr)
127  (let* ((rules (sgm-rules))
128         (default (alist-ref '*default* rules)))
129    (cond ((alist-ref (car expr) rules)
130           => (lambda (make)
131                (apply make expr)))
132          (default (apply default expr))
133          (else
134           (error 'sgm->entry
135                  "No rule corresponding to type" (car expr))))))
136
137;;; Sending entries to client
138
139;; Sends one entry to the client.  e may be an entry object or
140;; an sgm item.
141(define (send-entry e)
142  (cond ((gopher:entry? e)
143         (gopher:send-entry e))
144        ((pair? e)
145         (gopher:send-entry (sgm->entry e)))
146        (else
147         (error 'send-entry
148                "Invalid entry" e))))
149
150;; Sends all entries in L to the client.
151(define (send-entries L)
152  (for-each send-entry L)
153  #t)
154
155
156;;; Handlers
157
158;;;; Filename utilities
159
160;; Sanitize filename FN; currently just removes any references
161;; to a parent directory "..".
162(define sanitize-filename
163  (let ((parent-dir (irregex '(: (or "/" bos)
164                                 ".."
165                                 (or "/" eos)))))
166    (lambda (fn)
167      (and (not (string-search parent-dir fn))
168           fn))))
169
170;; Converts a selector string into a filename string by prepending the
171;; ROOT path.  Also confirms the file exists and the user has read
172;; permission.  Returns #f on failure.
173(define (selector->filename s root)
174  (unless root
175    (error "Filesystem 'root' parameter not set"))
176  (and-let* ((fn (sanitize-filename (string-append root "/" s))))
177    (and (file-read-access? fn)
178         fn)))
179
180;;;; URL handler
181
182(define url-redirect-time (make-parameter 0)) ;; Redirect time, in seconds
183;; Meta redirect user to URL in first submatch of request, as provided
184;; by match-url.
185(define handle-url
186  (let ((url-escape-charset
187         (char-set-difference (char-set-complement char-set:uri-unreserved)
188                              char-set:gen-delims)))  ;; blechhh!!
189    (lambda (req)
190      (let ((url (uri-encode-string (car (request-matches req))
191                                    url-escape-charset)))
192        ;; Should we print to a port?
193        (printf "
194<html><head><title>phricken gopher server redirect page</title>
195            <meta http-equiv=\"refresh\" content=\"~A;url=~A\" />
196</head>
197<body>You will be redirected to <a href=\"~A\">~A</a> in ~A seconds.
198</body></html>" (url-redirect-time) url url url (url-redirect-time))
199        ((logger) 'redirect req "to " url)
200        #t))))
201
202;;;; File handler
203
204;; Expects to be attached to a resource (path is second submatch).
205(define (handle-file root)
206  (lambda (req)
207    (cond ((selector->filename (cadr (request-matches req)) root)
208           => (lambda (fn)
209                (if (regular-file? fn)
210                    (send-binary-file fn)
211                    #f)))
212          (else #f))))
213
214;;;; SGM handler
215
216;; If (sgm-filename) exists in the directory indicated by the selector,
217;; read the file contents as a Scheme Gopher Map and send the results.
218(define sgm-filename (make-parameter "index.sgm"))
219;; Expects to be attached to a resource (path is second submatch).
220(define (handle-sgm root)
221  (lambda (req)
222    (and-let* ((fn (selector->filename
223                    (string-append (cadr (request-matches req))
224                                   "/" (sgm-filename))
225                    root)))
226      (and (regular-file? fn)
227           (send-entries (read-file fn))))))
228
229;;;; Open directory handler
230
231;; Case-insensitive map of file extension (as symbol) to
232;; 1-character Gopher entry type (as symbol).
233(define extension-type-map
234  (make-parameter
235   `((txt . 0) (log . 0) (scm . 0) (sgm . 0) (c . 0) (h . 0)
236     (png . I) (gif . g) (jpg . I) (svg . I))))
237;; (Internal.) Look up extension EXT in (extension-type-map).
238(define (extension-type ext)
239  (alist-ref
240   (string->symbol
241    (string-downcase (or ext "")))  ; treat #f ext as empty
242   (extension-type-map)))
243;; Convert pathname (DIR is directory on disk; FN is basename of file
244;; on disk; DIR-SEL is the selector corresponding to DIR) into an
245;; entry (either an entry object or an SGM entry is permissible).
246;; Used by filenames->entres.
247;;
248;; The default procedure maps directories to type 1, other files based
249;; on (extension-type-map), and defaults to binary type 9.  Symbolic
250;; links are currently ignored.
251(define path->entry
252  (make-parameter
253   (lambda (dir fn dir-sel)
254     (define (path->entry-type dir fn)
255       (let ((path (string-append dir "/" fn)))
256         (cond ((directory? path) 1)
257               ((symbolic-link? path) #f)
258               ((regular-file? path)
259                (or (extension-type (pathname-extension fn))
260                    9))
261               (else #f))))
262     (let ((child-sel (string-append dir-sel "/" fn)))
263       (and-let* ((type (path->entry-type dir fn)))
264         `(,type ,fn ,child-sel))))))
265
266;; DIR is the containing directory on disk; BASENAMES are the
267;; basenames of the files, such as provided via the (directory dir)
268;; call; DIR-SEL is the absolute selector corresponding to this
269;; directory (not relative to any resource).
270(define (filenames->entries dir basenames dir-sel)
271  (filter-map
272   (lambda (fn)
273     ((path->entry) dir fn dir-sel))
274   basenames))
275
276;; Generate a directory listing for any directory under ROOT,
277;; using filenames->entries to determine how to generate an
278;; entry for each filename.  (Generated entries need not be
279;; file entries!)
280;; Expects to be attached to a resource (path is second submatch).
281(define (handle-open-dir root)
282  (lambda (req)
283    ;; if paranoid, run selector->filename on generated name
284    (and-let* ((sel (request-selector req))
285               (relative-dir-sel (cadr (request-matches req)))
286               (dir (selector->filename relative-dir-sel root)))
287      (and (directory? dir)
288           (let ((contents (sort (directory dir) string<?))) ; ignore dotfiles
289             (send-entries
290              `((i "Contents of " ,sel)
291                (i)
292                ,@(filenames->entries dir contents sel))))))))
293
294;;; Selector matching for handlers
295
296;; Match incoming selector against regex RX using string-match, and calls
297;; HANDLER with the request object.  Any submatches will be added to
298;; the MATCHES field of the request (i.e., the CDR of the result of
299;; string-match).
300(define (match-selector rx handler)
301  (lambda (req)
302    (and-let* ((matches (string-match rx (request-selector req))))
303      (handler (make-request (request-selector req)
304                             (cdr matches) ; first match is always selector
305                             (request-extra req))))))
306
307;; Match resource.  Just a shortcut for match-selector, which matches
308;; the directory (posix-string or SRE) you provide as 'resource', plus
309;; optional subdirectory path.  E.g., "/wiki" will match
310;; "(/wiki)($|/*)" and provide those two submatches in the request.
311(define (match-resource resource handler)
312  (define (maybe-string->sre rx)
313    (if (string? rx) (string->sre rx) rx))
314  (let* ((sre (maybe-string->sre resource))
315         (rx (irregex `(: (submatch ,sre)
316                          (submatch (or eos (: "/" (* any))))))))
317    (match-selector rx handler)))
318
319;; Matcher for URL selectors; first submatch will be the URL.
320(define (match-url handler)
321  (match-selector '(: "URL:" (submatch (+ any)))
322                  handler))
323
324;; Utility function which 'mounts' fs ROOT on resource selector SEL.
325;; Handlers used are handle-sgm, handle-open-dir, handle-file.
326(define (bind-fs sel root)
327  (match-resource
328   sel
329   (any-handler (handle-sgm root)
330                (handle-open-dir root)
331                (handle-file root))))
332
333;; Execute HANDLERS in order and return first true value, or #f.
334(define (any-handler . handlers)
335  (lambda (req)
336    (any (lambda (h) (h req))
337         handlers)))
338
339;;; Handle requests
340
341;; Handlers are executed in order until one returns a true value.
342;; If a handler throws an exception, processing terminates immediately.
343;; Each handler is passed a request object.
344
345(define handlers (make-parameter #f))
346
347(define (handle-request selector extra)
348  (let ((req (make-request selector '() extra)))
349      (handle-exceptions exn
350          (begin (send-entry '(3 "Internal server error."))
351                 ((logger) 'error req
352                         (string-intersperse
353                          (cons ((condition-property-accessor
354                                  'exn 'message) exn)
355                                (map ->string
356                                     ((condition-property-accessor
357                                       'exn 'arguments) exn)))
358                          ": "))
359                 (signal exn))
360        ;; Log immediately upon request receipt, instead of after handler.
361        ;; Noisier, but handler logging appears in correct order.
362        (if (null? extra)
363            ((logger) 'access req)
364            ((logger) 'access req
365                    (with-output-to-string (lambda ()
366                                             (write extra)))))
367        (or (any (lambda (h) (h req))
368                 (handlers))
369            (begin (send-entry `(3 "Invalid selector " ,selector))
370                   ((logger) 'error req "Invalid selector"))))))
371
372;;; Start/stop server
373
374(define (start-server! #!optional (bg #f))
375  (let ((server
376         (make-tcp-server
377          (tcp-listen (port))
378          (lambda ()
379            (let-values (((local remote)
380                          (tcp-addresses (current-output-port))))
381              (parameterize ((client-ip remote))
382                ((logger) 'connect #f)
383                (gopher:accept handle-request)))))))
384    (parameterize ((tcp-buffer-size 16384))
385      (if bg
386          (thread-start! server)
387          (server)))))
388
389;; (define (stop-server!)
390;;   (when (server-thread)
391;;    (thread-terminate! (server-thread))  ; Unsafe and won't close port
392;;    (server-thread #f)))
393)
394
395;; Copyright (c) 2009 Jim Ursetto.  All rights reserved.
396;;
397;; Redistribution and use in source and binary forms, with or without
398;; modification, are permitted provided that the following conditions are met:
399;;
400;;  Redistributions of source code must retain the above copyright notice,
401;;   this list of conditions and the following disclaimer.
402;;  Redistributions in binary form must reproduce the above copyright notice,
403;;   this list of conditions and the following disclaimer in the documentation
404;;   and/or other materials provided with the distribution.
405;;  Neither the name of the author nor the names of its contributors
406;;   may be used to endorse or promote products derived from this software
407;;   without specific prior written permission.
408;;
409;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
410;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
411;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
412;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
413;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
414;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
415;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
416;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
417;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
418;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
419;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
420
Note: See TracBrowser for help on using the repository browser.