source: project/release/4/phricken/trunk/phricken.scm @ 13268

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

add gopher (yes, gopher) and phricken eggs to chicken 4

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