#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SHP: Hypertext Processor
;;
;; a PHP like web framework for PLT Scheme
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; handler.ss
;; yc 8/12/2009
;; yc 8/13/2009 - added request & response
(require mzlib/trace
         scheme/contract
         scheme/list
         net/url 
         web-server/http/request-structs
         web-server/http/response-structs
         web-server/dispatchers/dispatch
         "request.ss"
         "cookie.ss"
         "response.ss"
         "servlet.ss"
         )

;; read all terms
(define (read-all in)
  (define (helper acc)
    (let ((term (read in)))
      (if (eof-object? term)
          (reverse acc)
          (helper (cons term acc)))))
  (helper '()))

;; convert file into complete terms
(define (file->values path)
  (call-with-input-file path read-all)) 

(define (thunk? p)
  (and (procedure? p)
       (let ((a (procedure-arity p)))
         (cond ((arity-at-least? a)
                (= (arity-at-least-value a) 0))
               ((number? a) (= a 0))
               ((list? a) (member 0 a))))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; path related functions
;; takes a path and break it up into segments.
(define (path->segments path)
  (filter (lambda (path) 
            (not (equal? path "")))
          (if (url? path)
              (map path/param-path (url-path path))
              (regexp-split #px"\\/" path))))

;; normalize-path - returns an underlying path based on a input path
(define (normalize-path path (base (shp-handler-path ($server))))
  (apply build-path base (path->segments path)))

;; partially matching the path from the beginning of the path
(define (segments->partial-path segments)
  (define (helper rest path default)
    ;; if we did not find any match return not-found
    (cond ((null? rest) (build-path (shp-handler-path ($server)) 
                                    (shp-handler-not-found ($server)))) 
          ;; then we test to see if this is a directory path & whether the default file exists for the directory
          ((file-exists? (build-path path (car rest) default)) 
           ($pathinfo (cdr rest)) ;; updating the pathinfo so it can be accessed.
           (build-path path (car rest) default))
          ((file-exists? (build-path path (car rest))) ;; otherwise the segment is a file and see if it exists...
           ($pathinfo (cdr rest)) ;; udpdating the pathinfo so it can be accessed.
           (build-path path (car rest)))
          (else
           (helper (cdr rest) (build-path path (car rest)) default))))
  (helper segments (shp-handler-path ($server)) (shp-handler-default ($server))))

(define (segments->path segments (partial? #t))
  ;; test for full path first and then partial path.
  (let ((script (apply build-path (shp-handler-path ($server)) segments)))
    (cond ((file-exists? script) script)
          ((and (directory-exists? script)
                (file-exists? (build-path script (shp-handler-default ($server)))))
           (build-path script (shp-handler-default ($server))))
          (partial? 
           (segments->partial-path segments)) 
          (else 
           (build-path script (shp-handler-not-found ($server)))))))

(define (resolve-path path (partial? #t)) 
  (segments->path (path->segments path) partial?)) 

(define-namespace-anchor handler-namespace-anchor)

(define handler-namespace (namespace-anchor->namespace handler-namespace-anchor))

;; testing whether an expression is of the form (require ...)
(define (require-exp? term)
  (and (pair? term) (equal? (car term) 'require)))

;; add the require modules into the handler-namespace
(define (require-modules! terms)
  (define (helper modules)
    (parameterize ((current-namespace handler-namespace))
      (for-each (lambda (module)
                  (namespace-require module))
                modules)))
  (let ((modules (flatten (map cdr (filter require-exp? terms))))) 
    (helper modules)))

;; determining the args
(define (args-exp? term)
  (and (pair? term) (equal? (car term) ':args)))

;; get the args expressions
(define (terms->args terms) 
  (define (helper args)
    (cond ((null? args) '()) ;; if none just return null
          ((not (null? (cdr args))) ;; cannot have more than one
           (error 'filter-args "multiple args statement: ~a" args))
          (else (cdr (car args))))) 
  (helper (filter args-exp? terms)))

;; terms->exps
(define (terms->exps terms)
  (let ((exps (filter (lambda (exp)
                        (and (not (require-exp? exp))
                             (not (args-exp? exp))))
                      terms)))
    (if (null? exps) 
        '("") ;; ensure there is at least one exp in the lambda.
        exps)))

;; abstract the eval process
(define (evaluate-terms terms)
  (require-modules! terms) ;; first register the required modules
  ;; then we filter out the required statement and evaluate the rest of the terms as a proc.
  (eval `(lambda ,(terms->args terms) 
           . ,(terms->exps terms))
        handler-namespace))

(define (evaluate-script path)
  (evaluate-terms (file->values path)))

(define $server (make-parameter #f))

(define-struct script (path (timestamp #:mutable))) ;; for comparing to new timestamp

(define (init-script path (base (shp-handler-path ($server))))
  (let ((path (normalize-path path base)))
    (make-script path 0))) ;; 0 is epoch time.

(define (include! path 
                  #:topfilter (topfilter #f)
                  #:partial? (partial? #f)
                  . args) 
  (define (make-script path partial?)
    (evaluate-script (if (script? path)
                         (script-path path)
                         (resolve-path path partial?))))
  (define (helper topfilter)
    (let ((proc (make-script path partial?)))
      (if topfilter 
          (topfilter (lambda () (apply proc args)))
          (apply proc args))))
  (helper (if topfilter (make-script topfilter #f) topfilter)))

(define (eval-script-if-changed! script)
  (unless (not (file-exists? (script-path script)))
    (let ((timestamp (file-or-directory-modify-seconds (script-path script))))
      (when (> timestamp (script-timestamp script))
        (set-script-timestamp! script timestamp)
        (include! script)))))

(define (handle-request server request)
  (parameterize (($server server)
                 ($request request)
                 ($pathinfo ($pathinfo))
                 ($status ($status))
                 ($headers ($headers))
                 ($content-type ($content-type)))
    (parameterize (($cookies (init-cookies!)))
      (eval-script-if-changed! (shp-handler-required server))
      (with-handlers ((response/basic? 
                       (lambda (r) r)))
        (make-response (include! (request-uri request) 
                                 #:topfilter (shp-handler-topfilter server)
                                 #:partial? #t))))))

(define-struct shp-handler (path default not-found required topfilter)
  #:property prop:procedure
  (lambda ($struct request)
    (handle-request $struct request)))

(define (*make-shp-handler path 
                           #:default (default "index.shp") 
                           #:not-found (not-found "notfound.shp")
                           #:required (required "required.shp")
                           #:topfilter (topfilter #f)) 
  (make-shp-handler path default not-found (init-script required path) topfilter))

(define (punt!)
  (next-dispatcher))

;; contracts
(provide/contract
 (rename *make-shp-handler make-shp-handler
         (->* (path-string?) 
              (#:default path-string? 
                         #:not-found path-string? 
                         #:required path-string? 
                         #:topfilter (or/c #f path-string?)) 
              (-> request? response/c)))
 ($server (parameter/c (or/c #f shp-handler?)))
 )