Changeset 12135 in project
- Timestamp:
- 10/12/08 15:45:16 (12 years ago)
- Location:
- release/4/spiffy/trunk
- Files:
-
- 1 edited
- 3 copied
Legend:
- Unmodified
- Added
- Removed
-
release/4/spiffy/trunk/simple-directory-handler.scm
r12128 r12135 1 1 ;;;; simple-directory-handler.scm 2 2 ; 3 ; Copyright (c) 2007 , Peter Bex3 ; Copyright (c) 2007-2008, Peter Bex 4 4 ; Copyright (c) 2000-2005, Felix L. Winkelmann 5 5 ; All rights reserved. 6 6 ; 7 ; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following 8 ; conditions are met: 7 ; Redistribution and use in source and binary forms, with or without 8 ; modification, are permitted provided that the following conditions 9 ; are met: 9 10 ; 10 ; Redistributions of source code must retain the above copyright notice, this list of conditions and the following 11 ; disclaimer. 12 ; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following 13 ; disclaimer in the documentation and/or other materials provided with the distribution. 14 ; Neither the name of the author nor the names of its contributors may be used to endorse or promote 15 ; products derived from this software without specific prior written permission. 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. 16 19 ; 17 ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS 18 ; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY 19 ; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR 20 ; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 21 ; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 23 ; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 24 ; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 25 ; POSSIBILITY OF SUCH DAMAGE. 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. 26 32 27 (declare 28 (export simple-directory-handler simple-directory-css simple-directory-dotfiles? simple-directory-display-file)) 33 (module simple-directory-handler 34 (simple-directory-handler simple-directory-dotfiles? 35 simple-directory-display-file) 29 36 30 (define simple-directory-css (make-parameter 31 "body { 32 background-color: #d6c610; 33 font-family: Helvetica, Arial, sans-serif; 34 } 35 td { 36 padding: 0 1em; 37 font-family: Courier, monospace; 38 } 39 .directory { 40 font-weight: bold; 41 } 42 #server-name { 43 font-style: italic; 44 } 45 .size { 46 text-align:right; 47 }")) 37 (import chicken scheme srfi-1 extras spiffy files posix data-structures ports) 38 (require-extension intarweb) 48 39 49 40 (define simple-directory-dotfiles? (make-parameter #f)) … … 51 42 (make-parameter 52 43 (lambda (remote-file local-file dir?) 53 (printf "<tr><td class=\"~a\"><a href=\"~a\">~a</a></td><td class=\"size\">~a</td><td class=\"modification-time\">~a</td></tr>~%" 54 (if dir? "directory" "file") 44 (sprintf "<tr> 45 <td><a href=\"~a\">~a</a></td> 46 <td>~a</td> 47 <td>~a</td> 48 </tr>\n" 55 49 remote-file 56 50 (htmlize (pathname-strip-directory remote-file)) … … 59 53 60 54 (define (simple-directory-handler path) 61 (let ([str (with-output-to-string 62 (lambda () 63 (printf "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\"><html lang=\"en\"><head><style type=\"text/css\">~a></style><title>Index of ~a</title></head><body><h2>Index of ~a:</h2> 64 <p><a id=\"parent-link\" href=\"~a\">Go to parent directory</a></p><table>" 65 (simple-directory-css) 66 (current-path) 67 (current-path) 68 (pathname-directory (current-path))) 69 (let ([dir (sort (directory path (simple-directory-dotfiles?)) string<?)]) 70 (for-each 71 (lambda (file) 72 (let* ((local-file (make-pathname path file)) 73 (remote-file (make-pathname (current-path) file)) 74 (dir? (directory? local-file))) 75 (when (file-exists? local-file) 76 ((simple-directory-display-file) remote-file local-file dir?)))) 77 dir) 78 (display "</table><hr />") 79 (printf "<p id=\"server-name\">~A at ~A, port ~A</p></body></html>" 80 (spiffy-server-name) (get-host-name) (spiffy-tcp-port)) ) ) ) ] ) 81 (set-header! "Content-type: text/html") 82 (set-header! (sprintf "Content-length: ~A" (string-length str))) 83 (write-response-header) 84 (display str))) 55 (let ([str 56 (sprintf 57 "<!DOCTYPE html PUBLIC 58 \"-//W3C//DTD XHTML 1.0 Strict//EN\" 59 \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\"> 60 <html lang=\"en\"> 61 <head> 62 <title>Index of ~a</title> 63 </head> 64 <body> 65 <h2>Index of ~a:</h2> 66 <p><a href=\"~a\">Go to parent directory</a></p> 67 <table>~a</table> 68 </body> 69 </html>" 70 path 71 path 72 (or (pathname-directory path) path) 73 (let ([dir (sort (directory (make-pathname (root-path) path) 74 (simple-directory-dotfiles?)) 75 string<?)]) 76 (fold 77 (lambda (file str) 78 (let* ((local-file (make-pathname (list (root-path) path) 79 file)) 80 (remote-file (make-pathname path file)) 81 (dir? (directory? local-file))) 82 (if (file-exists? local-file) 83 (string-append str ((simple-directory-display-file) 84 remote-file local-file dir?)) 85 str))) 86 "" 87 dir)))]) 88 (with-headers `((content-type text/html) 89 (content-length ,(string-length str))) 90 (lambda () 91 (write-response (current-response)) 92 (display str (response-port (current-response))))))) 93 ) -
release/4/spiffy/trunk/spiffy.scm
r12035 r12135 39 39 (start-server with-headers send-status send-static-file 40 40 current-request current-response current-file current-pathinfo 41 root-path server-port index-files mime-type-map default-mime-type42 file-extension-handlers default-host vhost-map41 server-software root-path server-port index-files mime-type-map 42 default-mime-type file-extension-handlers default-host vhost-map 43 43 handle-directory handle-not-found 44 restart-request )44 restart-request htmlize log) 45 45 46 46 (import chicken scheme extras ports files data-structures) … … 58 58 59 59 ;;; Configuration 60 (define server-software (make-parameter (conc "Spiffy/" version "." release))) 60 61 (define root-path (make-parameter "./web")) 61 62 (define server-port (make-parameter 8080)) … … 158 159 (if index-page 159 160 (process-entry (make-pathname path index-page) '()) 160 ((handle-directory) path))))161 ((handle-directory) (make-pathname "/" path))))) 161 162 162 163 ;; If an URL is missing a trailing slash, instead of directly serving … … 177 178 ((directory? path) 178 179 (match remaining-path 179 (() (redirect-directory-root current-path))180 (() (redirect-directory-root (make-pathname "/" current-path))) 180 181 (("/") (process-directory current-path)) 181 182 (else (process-entry (make-pathname current-path (car remaining-path)) … … 184 185 (parameterize ((current-pathinfo remaining-path) 185 186 (current-file path)) 186 ((handle-file) current-path)))187 (else ((handle-not-found) current-path)))))187 ((handle-file) (make-pathname "/" current-path)))) 188 (else ((handle-not-found) (list "/" current-path)))))) 188 189 189 190 ;; Determine the vhost and port to use. This follows RFC 2616, section 5.2: … … 248 249 (close-input-port in)))) 249 250 251 (define (htmlize str) 252 (string-translate* str '(("<" . "<") 253 (">" . ">") 254 ("\"" . """) 255 ("&" . "&")))) 256 250 257 (define (start-server #!key (port (server-port))) 251 258 (letrec ((listener (tcp-listen port)) -
release/4/spiffy/trunk/ssp-handler.scm
r12128 r12135 5 5 ; All rights reserved. 6 6 ; 7 ; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following 8 ; conditions are met: 7 ; Redistribution and use in source and binary forms, with or without 8 ; modification, are permitted provided that the following conditions 9 ; are met: 9 10 ; 10 ; Redistributions of source code must retain the above copyright notice, this list of conditions and the following 11 ; disclaimer. 12 ; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following 13 ; disclaimer in the documentation and/or other materials provided with the distribution. 14 ; Neither the name of the author nor the names of its contributors may be used to endorse or promote 15 ; products derived from this software without specific prior written permission. 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. 16 19 ; 17 ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS 18 ; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY 19 ; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR 20 ; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 21 ; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 23 ; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 24 ; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 25 ; POSSIBILITY OF SUCH DAMAGE. 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. 26 32 ; 27 33 ; SSP file handler 28 34 29 (declare 30 (export ssp-handler include-ssp ssp-stringize ssp-short-open-tag ssp-long-open-tag ssp-close-tag ssp-eval-environment) ) 35 (module ssp-handler 36 (ssp-handler include-ssp ssp-stringize ssp-short-open-tag ssp-long-open-tag 37 ssp-close-tag ssp-eval-environment current-workdir) 38 39 (import chicken scheme spiffy extras ports regex files posix) 40 (require-extension matchable intarweb) 41 42 (define current-workdir (make-parameter #f)) 31 43 32 44 (define ssp-eval-environment (make-parameter (interaction-environment))) 33 45 34 46 (define (ssp-handler fn) 35 (let* ([out (ssp-stringize (pathname-strip-directory fn))]) 36 (set-header! (sprintf "Content-Length: ~A" (string-length out))) 37 (write-response-header) 38 (unless (eq? 'HEAD (http:request-method (current-request))) 39 (display out) ) ) ) 47 (let ([out (ssp-stringize fn)]) 48 (with-headers `((content-type text/html) 49 (content-length ,(string-length out))) 50 (lambda () 51 (write-response (current-response)) 52 (display out (response-port (current-response))))))) 40 53 41 54 (define ssp-close-tag "\\?>") … … 65 78 (display "\n(display \"") 66 79 (scan end) ] 67 [_ (spiffy-debug "Warning: missing closing tag (~S)" ssp-close-tag)80 [_ #;(log 'debug "Warning: missing closing tag (~S)" ssp-close-tag) 68 81 (display "\n; Warning: missing closing tag\n") ] ) ) 69 82 (define (slashify-char c) … … 85 98 86 99 (define (ssp-stringize path) 87 88 (fn (make-pathname (make-pathname (spiffy-root-path) cwd) path)))89 90 91 92 (spiffy-debug "(ssp) translating file ~A ..." fn)93 (translate-file fn))94 100 (let* ((cwd (current-workdir)) 101 (fn (make-pathname (make-pathname (root-path) cwd) path))) 102 (parameterize ([current-workdir (make-pathname cwd (pathname-directory path))]) 103 (let ([fn2 (pathname-replace-extension fn "sspx")]) 104 (when (or (not (file-exists? fn2)) (< (file-modification-time fn2) (file-modification-time fn))) 105 #;(log 'debug "(ssp) translating file ~A ..." fn) 106 (translate-file fn)) 107 (load-scheme fn2))))) 95 108 96 109 (define (load-scheme fn) … … 103 116 104 117 (define (load-scheme-file filename) 105 (spiffy-debug "Loading ~A ..." filename)118 #;(log 'debug "Loading ~A ..." filename) 106 119 (call/cc 107 120 (lambda (return) 108 (parameterize ( [load-verbose #f]109 [exit-handler (lambda _ (return #f))])110 (load filename (cut eval <> (ssp-eval-environment))) ) ) ))121 (parameterize (#;(load-verbose #f) 122 (exit-handler (lambda _ (return #f)))) 123 (load filename (cut eval <> (ssp-eval-environment))))))) 111 124 125 ) -
release/4/spiffy/trunk/web-scheme-handler.scm
r12128 r12135 5 5 ; All rights reserved. 6 6 ; 7 ; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following 8 ; conditions are met: 7 ; Redistribution and use in source and binary forms, with or without 8 ; modification, are permitted provided that the following conditions 9 ; are met: 9 10 ; 10 ; Redistributions of source code must retain the above copyright notice, this list of conditions and the following 11 ; disclaimer. 12 ; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following 13 ; disclaimer in the documentation and/or other materials provided with the distribution. 14 ; Neither the name of the author nor the names of its contributors may be used to endorse or promote 15 ; products derived from this software without specific prior written permission. 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. 16 19 ; 17 ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS 18 ; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY 19 ; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR 20 ; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 21 ; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 23 ; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 24 ; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 25 ; POSSIBILITY OF SUCH DAMAGE. 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 ; Please report bugs, suggestions and ideas to the Chicken Trac 34 ; ticket tracking system (assign tickets to user 'sjamaan'): 35 ; http://trac.callcc.org 26 36 ; 27 37 ; Web-scheme file handler 28 38 29 ( declare30 ( export web-scheme-handler web-scheme-eval-environment))39 (module web-scheme-handler 40 (web-scheme-handler web-scheme-eval-environment) 31 41 42 (import chicken scheme spiffy extras intarweb ports files) 43 32 44 (define web-scheme-eval-environment (make-parameter (interaction-environment))) 33 45 34 (define- macro (swallow-output . exprs)35 ( let ((ret (gensym))36 (str (gensym)))37 `(let* ((,ret "")38 (,str (with-output-to-string39 (lambda () (set! ,ret (begin ,@exprs))))))40 (if (string? ,ret)41 (string-append ,str (->string ,ret))42 ,str))))46 (define-syntax swallow-output 47 (syntax-rules () 48 ((_ expr ...) 49 (let* ((ret "") 50 (str (with-output-to-string 51 (lambda () (set! ret (begin expr ...)))))) 52 (if (string? ret) 53 (string-append str ret) 54 str))))) 43 55 44 56 (define (load-ws file) 45 (swallow-output (eval `(begin ,@(read-file file)) (web-scheme-eval-environment)))) 57 (swallow-output 58 (eval `(begin ,@(read-file file)) (web-scheme-eval-environment)))) 46 59 47 60 (define (web-scheme-handler fn) 48 (let* ([out (load-ws fn)]) 49 (set-header! (sprintf "Content-Length: ~A" (string-length out))) 50 (write-response-header) 51 (unless (eq? 'HEAD (http:request-method (current-request))) 52 (display out) ) ) ) 61 (let* ([out (load-ws (make-pathname (root-path) fn))]) 62 (with-headers `((content-type text/html) 63 (content-length ,(string-length out))) 64 (lambda () 65 (write-response (current-response)) 66 (display out (response-port (current-response))))))) 53 67 68 )
Note: See TracChangeset
for help on using the changeset viewer.