source: project/release/4/spiffy/trunk/ssp-handler.scm @ 12520

;;;; ssp-handler.scm
;
; Copyright (c) 2007, 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.
;
; SSP file handler

(module ssp-handler
  (ssp-handler ssp-include ssp-stringize ssp-short-open-tag ssp-long-open-tag
   ssp-close-tag ssp-eval-environment current-workdir exit-handler)

(import chicken scheme spiffy extras ports regex files posix)
(require-extension matchable intarweb)

(define current-workdir (make-parameter #f))
(define exit-handler    (make-parameter #f))

(define ssp-eval-environment (make-parameter (interaction-environment)))

(define (ssp-handler fn)
  (let ([out (ssp-stringize fn)])
  (with-headers `((content-type text/html)
                  (content-length ,(string-length out)))
    (lambda ()
      (write-response (current-response))
      (display out (response-port (current-response)))))))

(define ssp-close-tag "\\?>")
(define ssp-short-open-tag "<\\?")
(define ssp-long-open-tag "<\\?scheme($|[ \n\t])")

(define (translate-file fname)
  (let* ([new (pathname-replace-extension fname "sspx")]
         [rx (regexp (string-append ssp-long-open-tag "|" ssp-short-open-tag))]
         [rx2 (regexp ssp-close-tag)] 
         [buffer (with-input-from-file fname read-string)] )
    (define (scan pos)
      (match (string-search-positions rx buffer pos)
        [((start end) . _)
         (slashify (substring buffer pos start))
         (display "\")\n")
         (let ([s (string-match ssp-short-open-tag (substring buffer start end))])
           (when s (display "(display "))
           (skip end s) ) ]
        [_ (slashify (substring buffer pos (string-length buffer)))
           (display "\") )\n; End of file\n") ] ) )
    (define (skip pos f)
      (match (string-search-positions rx2 buffer pos)
        [((start end) . _)
         (display (substring buffer pos start))
         (when f (write-char #\)))
         (display "\n(display \"")
         (scan end) ]
        [_ #;(log 'debug "Warning: missing closing tag (~S)" ssp-close-tag)
           (display "\n; Warning: missing closing tag\n") ] ) )
    (define (slashify-char c)
      (case c
        [(#\newline) (display "\\n")]
        [(#\return) (display "\\r")]
        [(#\tab) (display "\\t")]
        [(#\") (display "\\\"")]
        [(#\\) (display "\\\\")]
        [else (write-char c)] ) )
    (define (slashify s)
      (do ([i 0 (add1 i)])
          ((>= i (string-length s)))
        (slashify-char (string-ref s i))))
    (with-output-to-file new
      (lambda ()
        (printf "; Translation of file ~A:\n(let () (display \"" fname)
        (scan 0)))))

(define (ssp-stringize path)
  (let* ((cwd (current-workdir))
         (fn (make-pathname (make-pathname (root-path) cwd) path)))
    (parameterize ([current-workdir (make-pathname cwd (pathname-directory path))])
      (let ([fn2 (pathname-replace-extension fn "sspx")])
        (when (or (not (file-exists? fn2)) (< (file-modification-time fn2) (file-modification-time fn)))
              #;(log 'debug "(ssp) translating file ~A ..." fn)
              (translate-file fn))
        (load-scheme fn2)))))

(define (load-scheme fn)
  (with-output-to-string
    (lambda ()
      (load-scheme-file fn))))

(define (ssp-include fn)
  (display (ssp-stringize fn)))

(define (load-scheme-file filename)
  #;(log 'debug "Loading ~A ..." filename)
  (call/cc
   (lambda (return)
     (parameterize ((load-verbose #f)
                    (exit-handler (lambda _ (return #f))))
       (load filename (cut eval <> (ssp-eval-environment)))))))

)