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

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

Simplify call to read-string, drop loading of matchable (even though it isn't needed anymore it was still loaded)

File size: 6.1 KB
Line 
1;;;; ssp-handler.scm
2;
3; Copyright (c) 2007-2012, 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)
41(use spiffy intarweb extras irregex files posix (only ports with-output-to-string))
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         [long-open (maybe-string->sre (ssp-long-open-tag))]
75         [short-open (maybe-string->sre (ssp-short-open-tag))]
76         [rx (irregex `(or ,long-open ,short-open))]
77         [rx2 (irregex (ssp-close-tag))]
78         [buffer (read-string (make-pathname (root-path) fname))] )
79    (define (scan pos)
80      (cond
81       ((irregex-search rx buffer pos) =>
82        (lambda (m)
83          (let ((start (irregex-match-start-index m)))
84           (slashify (substring buffer pos start))
85           (display "\")\n")
86           (let* ((end (irregex-match-end-index m))
87                  (s (irregex-match short-open (substring buffer start end))))
88             (when s (display "(display "))
89             (skip end s) )) ))
90       (else (slashify (substring buffer pos (string-length buffer)))
91             (display "\") )\n; End of file\n"))  ) )
92    (define (skip pos f)
93      (cond
94       ((irregex-search rx2 buffer pos) =>
95        (lambda (m)
96          (display (substring buffer pos (irregex-match-start-index m)))
97          (when f (write-char #\)))
98          (display "\n(display \"")
99          (scan (irregex-match-end-index m))))
100       (else (log-to (debug-log) "(ssp) Warning: missing closing tag (~S)" (ssp-close-tag))
101             (display (substring buffer pos (string-length buffer)))
102             (when f (write-char #\)))
103             (display ")\n; Warning: missing closing tag at end of file\n"))) )
104    (define (slashify-char c)
105      (case c
106        [(#\newline) (display "\\n")]
107        [(#\return) (display "\\r")]
108        [(#\tab) (display "\\t")]
109        [(#\") (display "\\\"")]
110        [(#\\) (display "\\\\")]
111        [else (write-char c)] ) )
112    (define (slashify s)
113      (do ([i 0 (add1 i)])
114          ((>= i (string-length s)))
115        (slashify-char (string-ref s i))))
116    (log-to (debug-log) "(ssp) Writing translation to file ~A~%" new)
117    (unless (file-exists? (pathname-directory new))
118      (create-directory (pathname-directory new) #t))
119    (with-output-to-file new
120      (lambda ()
121        (printf "; Translation of file ~A:\n(let () (display \"" fname)
122        (scan 0)))))
123
124(define (ssp-stringize path)
125  (let* ((cwd (current-workdir))
126         (fn (make-pathname cwd path)))
127    (parameterize ([current-workdir (make-pathname cwd (pathname-directory path))])
128      (let ([fn2 (make-cache-path fn)])
129        (when (or (not (file-exists? fn2))
130                  (< (file-modification-time fn2)
131                     (file-modification-time (make-pathname (root-path) fn))))
132              (log-to (debug-log) "(ssp) translating file ~A ..." fn)
133              (translate-file fn))
134        (load-scheme fn2)))))
135
136(define (load-scheme fn)
137  (with-output-to-string
138    (lambda ()
139      (load-scheme-file fn))))
140
141(define (ssp-include fn)
142  (display (ssp-stringize fn)))
143
144(define (load-scheme-file filename)
145  (log-to (debug-log) "(ssp) loading ~A ..." filename)
146  (call/cc
147   (lambda (return)
148     (parameterize ((load-verbose #f)
149                    (ssp-exit-handler (lambda _ (return #f))))
150       (load filename (cut eval <> (ssp-eval-environment)))))))
151
152)
Note: See TracBrowser for help on using the repository browser.