source: project/release/4/spiffy/trunk/web-scheme-handler.scm @ 27099

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

spiffy: Simplify web-scheme-handler a little

File size: 2.9 KB
Line 
1;;;; web-scheme-handler.scm
2;
3; Copyright (c) 2007-2009, 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; Please report bugs, suggestions and ideas to the Chicken Trac
34; ticket tracking system (assign tickets to user 'sjamaan'):
35; http://trac.callcc.org
36;
37; Web-scheme file handler
38
39(module web-scheme-handler
40  (web-scheme-handler web-scheme-eval-environment)
41
42(import chicken scheme)
43(use spiffy intarweb (only extras read-file)
44     (only files make-pathname) (only ports with-output-to-string))
45 
46(define web-scheme-eval-environment (make-parameter (interaction-environment)))
47
48;; This is a little convoluted but allows a procedure to either return a
49;; string or write output to current-output-port.
50(define-syntax swallow-output
51  (syntax-rules ()
52    ((_ expr)
53     (let* ((ret "")
54            (str (with-output-to-string (lambda () (set! ret expr)))))
55       (if (string? ret)
56           (string-append str ret)
57           str)))))
58
59(define (load-ws file)
60  (swallow-output
61   (eval `(begin ,@(read-file file)) (web-scheme-eval-environment))))
62
63(define (web-scheme-handler fn)
64  (let* ([out (load-ws (make-pathname (root-path) fn))])
65    (with-headers `((content-type text/html)
66                    (content-length ,(string-length out)))
67      (lambda ()
68       (write-logged-response)
69       (unless (eq? 'HEAD (request-method (current-request)))
70         (display out (response-port (current-response))))))))
71
72)
Note: See TracBrowser for help on using the repository browser.