1 | ;;;; ssp-handler.scm |
---|
2 | ; |
---|
3 | ; Copyright (c) 2007, 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 exit-handler) |
---|
38 | |
---|
39 | (import chicken scheme spiffy extras ports regex files posix) |
---|
40 | (require-extension matchable intarweb) |
---|
41 | |
---|
42 | (define current-workdir (make-parameter #f)) |
---|
43 | (define exit-handler (make-parameter #f)) |
---|
44 | |
---|
45 | (define ssp-eval-environment (make-parameter (interaction-environment))) |
---|
46 | |
---|
47 | (define (ssp-handler fn) |
---|
48 | (let ([out (ssp-stringize fn)]) |
---|
49 | (with-headers `((content-type text/html) |
---|
50 | (content-length ,(string-length out))) |
---|
51 | (lambda () |
---|
52 | (write-response (current-response)) |
---|
53 | (display out (response-port (current-response))))))) |
---|
54 | |
---|
55 | (define ssp-close-tag "\\?>") |
---|
56 | (define ssp-short-open-tag "<\\?") |
---|
57 | (define ssp-long-open-tag "<\\?scheme($|[ \n\t])") |
---|
58 | |
---|
59 | (define (translate-file fname) |
---|
60 | (let* ([new (pathname-replace-extension fname "sspx")] |
---|
61 | [rx (regexp (string-append ssp-long-open-tag "|" ssp-short-open-tag))] |
---|
62 | [rx2 (regexp ssp-close-tag)] |
---|
63 | [buffer (with-input-from-file fname read-string)] ) |
---|
64 | (define (scan pos) |
---|
65 | (match (string-search-positions rx buffer pos) |
---|
66 | [((start end) . _) |
---|
67 | (slashify (substring buffer pos start)) |
---|
68 | (display "\")\n") |
---|
69 | (let ([s (string-match ssp-short-open-tag (substring buffer start end))]) |
---|
70 | (when s (display "(display ")) |
---|
71 | (skip end s) ) ] |
---|
72 | [_ (slashify (substring buffer pos (string-length buffer))) |
---|
73 | (display "\") )\n; End of file\n") ] ) ) |
---|
74 | (define (skip pos f) |
---|
75 | (match (string-search-positions rx2 buffer pos) |
---|
76 | [((start end) . _) |
---|
77 | (display (substring buffer pos start)) |
---|
78 | (when f (write-char #\))) |
---|
79 | (display "\n(display \"") |
---|
80 | (scan end) ] |
---|
81 | [_ #;(log 'debug "Warning: missing closing tag (~S)" ssp-close-tag) |
---|
82 | (display "\n; Warning: missing closing tag\n") ] ) ) |
---|
83 | (define (slashify-char c) |
---|
84 | (case c |
---|
85 | [(#\newline) (display "\\n")] |
---|
86 | [(#\return) (display "\\r")] |
---|
87 | [(#\tab) (display "\\t")] |
---|
88 | [(#\") (display "\\\"")] |
---|
89 | [(#\\) (display "\\\\")] |
---|
90 | [else (write-char c)] ) ) |
---|
91 | (define (slashify s) |
---|
92 | (do ([i 0 (add1 i)]) |
---|
93 | ((>= i (string-length s))) |
---|
94 | (slashify-char (string-ref s i)))) |
---|
95 | (with-output-to-file new |
---|
96 | (lambda () |
---|
97 | (printf "; Translation of file ~A:\n(let () (display \"" fname) |
---|
98 | (scan 0))))) |
---|
99 | |
---|
100 | (define (ssp-stringize path) |
---|
101 | (let* ((cwd (current-workdir)) |
---|
102 | (fn (make-pathname (make-pathname (root-path) cwd) path))) |
---|
103 | (parameterize ([current-workdir (make-pathname cwd (pathname-directory path))]) |
---|
104 | (let ([fn2 (pathname-replace-extension fn "sspx")]) |
---|
105 | (when (or (not (file-exists? fn2)) (< (file-modification-time fn2) (file-modification-time fn))) |
---|
106 | #;(log 'debug "(ssp) translating file ~A ..." fn) |
---|
107 | (translate-file fn)) |
---|
108 | (load-scheme fn2))))) |
---|
109 | |
---|
110 | (define (load-scheme fn) |
---|
111 | (with-output-to-string |
---|
112 | (lambda () |
---|
113 | (load-scheme-file fn)))) |
---|
114 | |
---|
115 | (define (ssp-include fn) |
---|
116 | (display (ssp-stringize fn))) |
---|
117 | |
---|
118 | (define (load-scheme-file filename) |
---|
119 | #;(log 'debug "Loading ~A ..." filename) |
---|
120 | (call/cc |
---|
121 | (lambda (return) |
---|
122 | (parameterize ((load-verbose #f) |
---|
123 | (exit-handler (lambda _ (return #f)))) |
---|
124 | (load filename (cut eval <> (ssp-eval-environment))))))) |
---|
125 | |
---|
126 | ) |
---|