Changeset 12135 in project


Ignore:
Timestamp:
10/12/08 15:45:16 (12 years ago)
Author:
sjamaan
Message:

Add back ssp, web-scheme and simple-directory handlers

Location:
release/4/spiffy/trunk
Files:
1 edited
3 copied

Legend:

Unmodified
Added
Removed

  • release/4/spiffy/trunk/simple-directory-handler.scm

    r12128 r12135  
    11;;;; simple-directory-handler.scm
    22;
    3 ; Copyright (c) 2007, Peter Bex
     3; Copyright (c) 2007-2008, Peter Bex
    44; Copyright (c) 2000-2005, Felix L. Winkelmann
    55; All rights reserved.
    66;
    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:
    910;
    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.
    1619;
    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.
    2632
    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)
    2936
    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)
    4839
    4940(define simple-directory-dotfiles? (make-parameter #f))
    … …  
    5142  (make-parameter
    5243   (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"
    5549             remote-file
    5650             (htmlize (pathname-strip-directory remote-file))
    … …  
    5953
    6054(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  
    3939  (start-server with-headers send-status send-static-file
    4040   current-request current-response current-file current-pathinfo
    41    root-path server-port index-files mime-type-map default-mime-type
    42    file-extension-handlers default-host vhost-map
     41   server-software root-path server-port index-files mime-type-map
     42   default-mime-type file-extension-handlers default-host vhost-map
    4343   handle-directory handle-not-found
    44    restart-request)
     44   restart-request htmlize log)
    4545
    4646(import chicken scheme extras ports files data-structures)
    … …  
    5858
    5959;;; Configuration
     60(define server-software  (make-parameter (conc "Spiffy/" version "." release)))
    6061(define root-path        (make-parameter "./web"))
    6162(define server-port      (make-parameter 8080))
    … …  
    158159    (if index-page
    159160        (process-entry (make-pathname path index-page) '())
    160         ((handle-directory) path))))
     161        ((handle-directory) (make-pathname "/" path)))))
    161162
    162163;; If an URL is missing a trailing slash, instead of directly serving
    … …  
    177178     ((directory? path)
    178179      (match remaining-path
    179        (()    (redirect-directory-root current-path))
     180       (()    (redirect-directory-root (make-pathname "/" current-path)))
    180181       (("/") (process-directory current-path))
    181182       (else  (process-entry (make-pathname current-path (car remaining-path))
    … …  
    184185      (parameterize ((current-pathinfo remaining-path)
    185186                     (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))))))
    188189
    189190;; Determine the vhost and port to use. This follows RFC 2616, section 5.2:
    … …  
    248249      (close-input-port in))))
    249250
     251(define (htmlize str)
     252  (string-translate* str '(("<" . "&lt;")
     253                           (">" . "&gt;")
     254                           ("\"" . "&quot;")
     255                           ("&" . "&amp;"))))
     256
    250257(define (start-server #!key (port (server-port)))
    251258  (letrec ((listener (tcp-listen port))

  • release/4/spiffy/trunk/ssp-handler.scm

    r12128 r12135  
    55; All rights reserved.
    66;
    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:
    910;
    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.
    1619;
    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.
    2632;
    2733; SSP file handler
    2834
    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))
    3143
    3244(define ssp-eval-environment (make-parameter (interaction-environment)))
    3345
    3446(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)))))))
    4053
    4154(define ssp-close-tag "\\?>")
    … …  
    6578         (display "\n(display \"")
    6679         (scan end) ]
    67         [_ (spiffy-debug "Warning: missing closing tag (~S)" ssp-close-tag)
     80        [_ #;(log 'debug "Warning: missing closing tag (~S)" ssp-close-tag)
    6881           (display "\n; Warning: missing closing tag\n") ] ) )
    6982    (define (slashify-char c)
    … …  
    8598
    8699(define (ssp-stringize path)
    87    (let* ((cwd (current-workdir))
    88           (fn (make-pathname (make-pathname (spiffy-root-path) cwd) path)))
    89      (parameterize ([current-workdir (make-pathname cwd (pathname-directory path))])
    90        (let ([fn2 (pathname-replace-extension fn "sspx")])
    91         (when (or (not (file-exists? fn2)) (< (file-modification-time fn2) (file-modification-time fn)))
    92                (spiffy-debug "(ssp) translating file ~A ..." fn)
    93                (translate-file fn) )
    94         (load-scheme fn2)))))
     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)))))
    95108
    96109(define (load-scheme fn)
    … …  
    103116
    104117(define (load-scheme-file filename)
    105   (spiffy-debug "Loading ~A ..." filename)
     118  #;(log 'debug "Loading ~A ..." filename)
    106119  (call/cc
    107120   (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)))))))
    111124
     125)

  • release/4/spiffy/trunk/web-scheme-handler.scm

    r12128 r12135  
    55; All rights reserved.
    66;
    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:
    910;
    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.
    1619;
    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
    2636;
    2737; Web-scheme file handler
    2838
    29 (declare
    30   (export web-scheme-handler web-scheme-eval-environment) )
     39(module web-scheme-handler
     40  (web-scheme-handler web-scheme-eval-environment)
    3141
     42(import chicken scheme spiffy extras intarweb ports files)
     43 
    3244(define web-scheme-eval-environment (make-parameter (interaction-environment)))
    3345
    34 (define-macro (swallow-output . exprs)
    35   (let ((ret (gensym))
    36         (str (gensym)))
    37     `(let* ((,ret "")
    38             (,str (with-output-to-string
    39                     (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)))))
    4355
    4456(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))))
    4659
    4760(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)))))))
    5367
     68)
Note: See TracChangeset for help on using the changeset viewer.