;;;; web-scheme-handler.scm
;
; Copyright (c) 2007-2009, Peter Bex
; Copyright (c) 2000-2005, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
;
; 1. Redistributions of source code must retain the above copyright
;    notice, this list of conditions and the following disclaimer.
; 2. Redistributions in binary form must reproduce the above copyright
;    notice, this list of conditions and the following disclaimer in the
;    documentation and/or other materials provided with the distribution.
; 3. Neither the name of the author nor the names of its
;    contributors may be used to endorse or promote products derived
;    from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
; OF THE POSSIBILITY OF SUCH DAMAGE.
;
; Please report bugs, suggestions and ideas to the Chicken Trac
; ticket tracking system (assign tickets to user 'sjamaan'):
; http://trac.callcc.org
;
; Web-scheme file handler

(module web-scheme-handler
  (web-scheme-handler web-scheme-eval-environment)

(import chicken scheme spiffy extras intarweb ports files)
  
(define web-scheme-eval-environment (make-parameter (interaction-environment)))

(define-syntax swallow-output
  (syntax-rules ()
    ((_ expr ...)
     (let* ((ret "")
            (str (with-output-to-string
                   (lambda () (set! ret (begin expr ...))))))
       (if (string? ret)
           (string-append str ret)
           str)))))

(define (load-ws file)
  (swallow-output
   (eval `(begin ,@(read-file file)) (web-scheme-eval-environment))))

(define (web-scheme-handler fn)
  (let* ([out (load-ws (make-pathname (root-path) fn))])
    (with-headers `((content-type text/html)
                    (content-length ,(string-length out)))
      (lambda ()
       (write-logged-response)
       (unless (eq? 'HEAD (request-method (current-request)))
         (display out (response-port (current-response))))))))

)