#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
;; yc 8/25/2009 - fixed the bug of throwing error instead of not-found when accessing scripts with args.
(require mzlib/trace
         mzlib/etc
         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"
         "proxy.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)
  (define (helper segments) 
    (filter (lambda (segment)
              (not (equal? segment "")))
            segments))
  ;; remove the "" at the beginning and the end, but not in the middle
  (helper (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)))

(define (not-found-path base)
  (let ((not-found (shp-handler-not-found ($server))))
    (if (script? not-found)
        (script-path not-found)
        (build-path base not-found))))

;; 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) 
           (not-found-path (shp-handler-path ($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 
           (not-found-path script)))))

(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 (require! module)
    (namespace-require module))
  (define (helper listof-modules)
    (parameterize ((current-namespace handler-namespace))
      (for-each (lambda (modules)
                  (for-each require! modules))
                listof-modules)))
  (helper (map cdr (filter require-exp? terms))))

;; 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 $chrome (make-parameter #f)) 

(define (make-chrome-based-handler inner) 
  (lambda () 
    (let ((result (inner))) 
      (if ($chrome) 
          ;; I see - chrome itself now will cause a recursion!!
          ((evaluate-script (resolve-path ($chrome) #f)) result)
          result))))

(define (include! path 
                  #:top? (top? #f)
                  #:topfilter (topfilter #f)
                  #:partial? (partial? #f)
                  #:chrome? (chrome? #f) 
                  . args) 
  (define (script-helper path partial?)
    (evaluate-script (if (script? path)
                         (script-path path)
                         (resolve-path path partial?))))
  (define (helper topfilter)
    (let ((proc 
           (let ((proc (script-helper path partial?)))
             (if (and top? (not (thunk? proc)))
                 (script-helper (shp-handler-not-found ($server)) #f)
                 proc))
           ))
      (let ((handler
             (let ((handler (lambda () (apply proc args))))
               (if chrome? (make-chrome-based-handler handler) handler))))
        (if topfilter 
            (topfilter handler)
            (handler)))))
  (helper (if topfilter (script-helper 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))
                 ($content-type ($content-type)))
    (parameterize (($cookies (init-cookies!))
                   ($headers (convert-headers))
                   ($chrome (shp-handler-chrome server)))
      (eval-script-if-changed! (shp-handler-required server))
      (with-handlers ((response/basic? 
                       (lambda (r) r)))
        (make-response (include! (request-uri request) 
                                 #:top? #t
                                 #:topfilter (shp-handler-topfilter server)
                                 #:chrome? #t
                                 #:partial? #t))))))

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

(define ($htdocs)
  (shp-handler-htdocs ($server))) 

(define (*make-shp-handler path 
                           #:default (default "index") 
                           #:not-found (not-found #f)
                           #:required (required "required")
                           #:topfilter (topfilter #f)
                           #:chrome (chrome #f)
                           #:htdocs (htdocs #f)) 
  (unless (directory-exists? path) 
    (error 'make-shp-handler "path ~a does not exist." path))
  (let ((htdocs 
         (let ((htdocs (if (not htdocs)
                           (build-path path 'up "file")
                           htdocs)))
           (if (directory-exists? htdocs)
               htdocs
               (error 'make-shp-handler "htdocs path ~a does not exist." htdocs)))))
    (make-shp-handler path 
                      default 
                      (if (not not-found)
                          (make-script (build-path (this-expression-source-directory) "example" "shp" "notfound") 0)
                          not-found)
                      (init-script required path) 
                      topfilter 
                      chrome
                      htdocs)))

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

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