;;;; 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 ssp-exit-handler
   ssp-cache-dir)

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

(define current-workdir (make-parameter #f))
(define ssp-exit-handler    (make-parameter #f))
(define ssp-cache-dir (make-parameter "."))

(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-logged-response)
      (display out (response-port (current-response)))))))

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

;; Given a pathname relative to docroot, get the matching cache filename.
;; This is either relative to the docroot itself, or somewhere else entirely.
(define (make-cache-path fn)
  (if (absolute-pathname? (ssp-cache-dir))
      (make-pathname (list (ssp-cache-dir) (pathname-directory fn))
		     (pathname-file fn) "sspx")
      (make-pathname (list (root-path) (ssp-cache-dir) (pathname-directory fn))
		     (pathname-file fn) "sspx")))

(define (translate-file fname)
  (let* ([new (normalize-pathname (make-cache-path fname))]
	 [rx (regexp (string-append (ssp-long-open-tag) "|" (ssp-short-open-tag)))]
	 [rx2 (regexp (ssp-close-tag))] 
	 [buffer (with-input-from-file (make-pathname (root-path) 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-to (debug-log) "(ssp) Warning: missing closing tag (~S)" (ssp-close-tag))
	   (display ")\n; Warning: missing closing tag at end of file\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))))
       (log-to (debug-log) "(ssp) Writing translation to file ~A~%" new)
       (unless (file-exists? (pathname-directory new))
               (create-directory (pathname-directory new) #t))
       (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 cwd path)))
    (parameterize ([current-workdir (make-pathname cwd (pathname-directory path))])
      (let ([fn2 (make-cache-path fn)])
        (when (or (not (file-exists? fn2))
                  (< (file-modification-time fn2)
		     (file-modification-time (make-pathname (root-path) fn))))
              (log-to (debug-log) "(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-to (debug-log) "(ssp) loading ~A ..." filename)
  (call/cc
   (lambda (return)
     (parameterize ((load-verbose #f)
		    (ssp-exit-handler (lambda _ (return #f))))
       (load filename (cut eval <> (ssp-eval-environment)))))))

)