source: project/release/4/spiffy/trunk/ssp-handler.scm @ 25623

Last change on this file since 25623 was 25623, checked in by sjamaan, 9 years ago

spiffy: Fix ssp-handler's pathname construction. Thanks to Karl for pointing this out.

File size: 5.7 KB
Line 
1;;;; ssp-handler.scm
2;
3; Copyright (c) 2007-2009, Peter Bex
4; Copyright (c) 2000-2005, Felix L. Winkelmann
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without
8; modification, are permitted provided that the following conditions
9; are met:
10;
11; 1. Redistributions of source code must retain the above copyright
12;    notice, this list of conditions and the following disclaimer.
13; 2. Redistributions in binary form must reproduce the above copyright
14;    notice, this list of conditions and the following disclaimer in the
15;    documentation and/or other materials provided with the distribution.
16; 3. Neither the name of the author nor the names of its
17;    contributors may be used to endorse or promote products derived
18;    from this software without specific prior written permission.
19;
20; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
23; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
24; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
25; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
26; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
27; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
28; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
29; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
31; OF THE POSSIBILITY OF SUCH DAMAGE.
32;
33; SSP file handler
34
35(module ssp-handler
36  (ssp-handler ssp-include ssp-stringize ssp-short-open-tag ssp-long-open-tag
37   ssp-close-tag ssp-eval-environment current-workdir ssp-exit-handler
38   ssp-cache-dir)
39
40(import chicken scheme spiffy extras ports regex files posix)
41(require-extension matchable intarweb)
42
43(define current-workdir (make-parameter #f))
44(define ssp-exit-handler    (make-parameter #f))
45(define ssp-cache-dir (make-parameter "."))
46
47(define ssp-eval-environment (make-parameter (interaction-environment)))
48
49(define (ssp-handler fn)
50  (let ([out (ssp-stringize fn)])
51  (with-headers `((content-type text/html)
52                  (content-length ,(string-length out)))
53    (lambda ()
54      (write-logged-response)
55      (unless (eq? 'HEAD (request-method (current-request)))
56        (display out (response-port (current-response))))))))
57
58(define ssp-close-tag (make-parameter "\\?>"))
59(define ssp-short-open-tag (make-parameter "<\\?"))
60(define ssp-long-open-tag (make-parameter "<\\?scheme($|[ \n\t])"))
61
62;; Given a pathname relative to docroot, get the matching cache filename.
63;; This is either relative to the docroot itself, or somewhere else entirely.
64(define (make-cache-path fn)
65  (if (absolute-pathname? (ssp-cache-dir))
66      (make-pathname (make-pathname (ssp-cache-dir) (pathname-directory fn))
67                     (pathname-file fn) "sspx")
68      (make-pathname (make-pathname (list (root-path) (ssp-cache-dir))
69                                    (pathname-directory fn))
70                     (pathname-file fn) "sspx")))
71
72(define (translate-file fname)
73  (let* ([new (normalize-pathname (make-cache-path fname))]
74         [rx (regexp (string-append (ssp-long-open-tag) "|" (ssp-short-open-tag)))]
75         [rx2 (regexp (ssp-close-tag))] 
76         [buffer (with-input-from-file (make-pathname (root-path) fname)
77                   read-string)] )
78    (define (scan pos)
79      (match (string-search-positions rx buffer pos)
80        [((start end) . _)
81         (slashify (substring buffer pos start))
82         (display "\")\n")
83         (let ([s (string-match (ssp-short-open-tag) (substring buffer start end))])
84           (when s (display "(display "))
85           (skip end s) ) ]
86        [_ (slashify (substring buffer pos (string-length buffer)))
87           (display "\") )\n; End of file\n") ] ) )
88    (define (skip pos f)
89      (match (string-search-positions rx2 buffer pos)
90        [((start end) . _)
91         (display (substring buffer pos start))
92         (when f (write-char #\)))
93         (display "\n(display \"")
94         (scan end) ]
95        [_ (log-to (debug-log) "(ssp) Warning: missing closing tag (~S)" (ssp-close-tag))
96           (display ")\n; Warning: missing closing tag at end of file\n")] ) )
97    (define (slashify-char c)
98      (case c
99        [(#\newline) (display "\\n")]
100        [(#\return) (display "\\r")]
101        [(#\tab) (display "\\t")]
102        [(#\") (display "\\\"")]
103        [(#\\) (display "\\\\")]
104        [else (write-char c)] ) )
105    (define (slashify s)
106      (do ([i 0 (add1 i)])
107          ((>= i (string-length s)))
108        (slashify-char (string-ref s i))))
109       (log-to (debug-log) "(ssp) Writing translation to file ~A~%" new)
110       (unless (file-exists? (pathname-directory new))
111               (create-directory (pathname-directory new) #t))
112       (with-output-to-file new
113         (lambda ()
114           (printf "; Translation of file ~A:\n(let () (display \"" fname)
115           (scan 0)))))
116
117(define (ssp-stringize path)
118  (let* ((cwd (current-workdir))
119         (fn (make-pathname cwd path)))
120    (parameterize ([current-workdir (make-pathname cwd (pathname-directory path))])
121      (let ([fn2 (make-cache-path fn)])
122        (when (or (not (file-exists? fn2))
123                  (< (file-modification-time fn2)
124                     (file-modification-time (make-pathname (root-path) fn))))
125              (log-to (debug-log) "(ssp) translating file ~A ..." fn)
126              (translate-file fn))
127        (load-scheme fn2)))))
128
129(define (load-scheme fn)
130  (with-output-to-string
131    (lambda ()
132      (load-scheme-file fn))))
133
134(define (ssp-include fn)
135  (display (ssp-stringize fn)))
136
137(define (load-scheme-file filename)
138  (log-to (debug-log) "(ssp) loading ~A ..." filename)
139  (call/cc
140   (lambda (return)
141     (parameterize ((load-verbose #f)
142                    (ssp-exit-handler (lambda _ (return #f))))
143       (load filename (cut eval <> (ssp-eval-environment)))))))
144
145)
Note: See TracBrowser for help on using the repository browser.