#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SHP: Hypertext Processor
;;
;; a PHP like web framework for PLT Scheme
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; shp.ss - adapts web-server servlet to shp and provide some top level request handlers
;;         - this module replaces handler.ss's starter loop.
;; yc 7/7/2010 - first version.

(require web-server/http/request-structs
         web-server/http/response-structs
         web-server/dispatchers/dispatch
         "base.ss"
         "depend.ss"
         "request.ss"
         "response.ss"
         "script.ss"
         "cookie.ss"
         "default.ss"
         "convert.ss"
         "query.ss" 
         "xmlrpc.ss" 
         "json.ss"
         )

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; handler-namespace
;; this namespace is provided to the shp scripts so they can refer to the same request objects.
(define-namespace-anchor handler-namespace-anchor)

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

(provide/contract 
 (handler-namespace namespace?))

;; punt! stops shp from handling the request and let web-server do the work.
(define (punt!)
  (next-dispatcher))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; handler adapters

;; (-> path-string-url? namespace? script?)
;; combines the path with the namespace to return the actual script object.
(define (evaluate path namespace) 
  (define (helper exp)
    (eval exp namespace))
  (for-each helper (file->values path)))

;; (-> shp? any)
;; load-required! will run the required script if it exists and modified.
;; if the script is run then all of the previous handlers will be cleared (so
;; the handlers can be regenerated with the newly modified namespace).
(define (load-required! shp) 
  (define (required?) 
    (with-handlers ((exn? (lambda (e) #f))
                    (http-result? (lambda (e) #f))) 
      (build-script-path shp (shp-config-ref shp 'required) #f)))
  (if-it (required?) 
         (let ((path (shp-config-ref shp 'required-path))) 
           (when (or (not path) (> (*path-mtime it) (*path-mtime path))) 
             (shp-config-set! shp 'required-path it)
             (evaluate (*path-full it) (shp-namespace shp))
             (registry-clear! (shp-handlers shp))))
         (void)))

;; (-> shp? (-> any) (-> any))
;; chrome-handler wraps the result of the inner handlers and return the values.
;; this is only usable with xexpr results currently.
(define (chrome-handler shp inner) 
  (lambda () 
    (let ((result (inner))) 
      (if ($chrome)
          ((ensure-script-handler! shp ($chrome)) result)
          result))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; api adapters

;; (-> inner hash?)
;; parse the xmlrpc post data into a hash.
(define (parse-xmlrpc inner) 
  (define (specs-helper script)
    (if (webcall? script)
        (args-converter-specs (webcall-args script)) 
        (specs-helper (script-inner script))))
  (define (match-composite-param-args args) 
    (define (helper rest-spec rest-args hash) 
      (cond ((null? rest-spec)
             hash)
            ((null? rest-args)
             hash)
            (else
             (let ((spec (car rest-spec)))
               (helper (cdr rest-spec)
                       (cdr rest-args)
                       (hash-set hash 
                                 (symbol->string (convert-spec-key spec)) 
                                 (car rest-args)))))))
    (helper (specs-helper inner) args (make-immutable-hash '())))
  (match-composite-param-args 
   (xmlrpc-params (xexpr->sxml 
                   (read-xexpr (open-input-bytes (normalize-xml-bytes ($post/raw))))))))

;; (-> inner? hash?)
;; depending on the request - return the api parameter (a hash).
;; the request can either be a post & xml => xmlrpc
;; a post & json => json
;; otherwise => query.
(define (parse-request-for-webcall inner) 
  ;; determine the content-type...
  (let((content-type (if-it ($header "Content-Type")
                             (read-content-type it)
                             #f)))
    (case ($method)
      ((post) 
       (cond ((and content-type
                   (string-ci=? (content-type/full content-type) "text/xml"))
              (parse-xmlrpc inner))
             ((and content-type 
                   (string-ci=? (content-type/full content-type) "text/json"))
              (read-json ($post/raw)))
             (else 
              (group-kvs ($queries)))))
      (else
       (group-kvs ($queries))))))
;; (trace parse-request-for-webcall)

;; (-> shp? script? script? status? response?)
;; handle the api call.  get the param based on the request, process, and then return the result
;; based on the request (i.e. if it's a text/json we will return json, text/xml will return xmlrpc).
;; this is currently hardcoded but could be extended in the future if we want to support additional
;; API types.
(define (handle-with-webcall shp inner topfilter status) 
  ;; this is the basic webcall that uses queries!
  ;; webcall's request & response format can be broken up!
  ;; but we won't tackle that immediately yet...
  (define (response-helper v status) 
    (define (result-helper) 
      (let ((content-type (if-it ($header "Content-Type")
                                 (read-content-type it)
                                 #f)))
        (case ($method) 
          ((post) 
           (cond ((and content-type
                       (string-ci=? (content-type/full content-type) "text/json"))
                  handle-json-result)
                 (else handle-xmlrpc-result)))
          (else handle-xmlrpc-result))))
    (make-response ((result-helper) (unconvert v)) status))
  (with-handlers ((exn? 
                   (lambda (e) 
                     (response-helper e 'internal-server-error))))
    (parameterize ((use-webcall? #t))
      (response-helper (if topfilter 
                           (topfilter (lambda () 
                                        (inner (parse-request-for-webcall inner))))
                           (inner (parse-request-for-webcall inner)))
                       status))))
;; (trace handle-with-webcall)

;; (-> shp? script? status? response?)
;; handles the request, and if it's a webcall, direct to handle-with-webcall.
(define (handle-with-topfilter shp inner (status ($status)))
  (define (is-webcall? script) 
    (if (script? script)
        (webcall? (script-inner script))
        (webcall? script)))
  (define (get-topfilter) 
    (if-it (shp-topfilter shp)
           (ensure-script-handler! shp it) 
           #f))
  (let ((topfilter (get-topfilter)))
    (if (is-webcall? inner)
        (handle-with-webcall shp inner topfilter status)
        (let ((inner (chrome-handler shp inner))) 
          (make-response (if topfilter 
                             (topfilter inner) 
                             (inner))
                         status)))))

;; (-> shp? status? response?)
;; when nothing else handles it - handle it here.
(define (handle-with-default-handler shp result) 
  (let* ((status (http-result-status result))
         (inner (with-handlers ((exn? 
                                 (lambda (e) 
                                   ;; this is not a script!
                                   (default-handler-ref ($status->code status)))))
                  (ensure-script-handler! 
                   shp 
                   (string-append "/" (symbol->string status))))))
    (handle-with-topfilter shp
                           (lambda () ;; this by default will take in parameters!
                             ;; this means that we need to handle the parameters
                             ;; returned in alternate statuses!
                             (apply inner (http-result-args result))))))

;; (trace handle-with-default-handler)

;; (-> shp? status? response?)
;; try to see if it is a webcall first (in case the webcall's path is separated between the uri path and the payload)
;; and if it is - redirect back to handle-top-handler , otherwise to handle-with-default-handler
;; a webcall's path can be hidden in the following:
;; a query key that starts with **
;; if xmlrpc - the xmlrpc-method name.
;; the above two parts can be drawn out to combine with the actual uri path (the ** prefix needs to be stripped)
;; to form the actual uri path, and it might exist.
(define (handle-via-webcall-first-then-default shp result) 
  (define (query-has-part-of-dispatcher)
    (define (helper kvs) 
      (if (null? kvs) 
          #f
          (let ((result (car kvs)))
            (substring (car result)
                       2
                       (string-length (car result))))))
    (helper (filter (lambda (kv) 
                      (and (>= (string-length (car kv)) 2)
                           (equal? (substring (car kv) 0 2) "**")))
                    ($queries))))
  (define (this-is-an-xmlrpc-post-call) 
    (let ((content-type (if-it ($header "Content-Type")
                               (read-content-type it) 
                               #f))) 
      (case ($method)
        ((post) 
         (if (string-ci=? (content-type/full content-type) "text/xml")
             ;; the answer is yes.
             (xmlrpc-method (xexpr->sxml (read-xexpr (open-input-bytes (normalize-xml-bytes ($post/raw))))))
             #f))
        (else #f))))
  (if (eq? (http-result-status result) 'not-found)
      (cond-it ((query-has-part-of-dispatcher)
                (with-handlers ((http-result? 
                                 (lambda (e)
                                   (display (format "error!: ~a~n" e)
                                            (current-error-port))
                                   (handle-with-default-handler shp result))))
                  (handle-top-handler shp (build-path (url-path/string ($uri)) 
                                                      it))))
               ((this-is-an-xmlrpc-post-call)
                (with-handlers ((http-result? 
                                 (lambda (e)
                                   (display (format "error!: ~a~n" e)
                                            (current-error-port))
                                   (handle-with-default-handler shp result))))
                  (handle-top-handler shp (build-path (url-path/string ($uri)) 
                                                      it))))
               (else
                (handle-with-default-handler shp result)))
      (handle-with-default-handler shp result)))

;; handle-top-handler
;; this is the top level handler without the parameterization.
(define (handle-top-handler shp path)
  (handle-with-topfilter shp (ensure-script-handler! shp path)))

;; handle-request
;; ensure the parameterizations are managed properly before calling handle-top-handler
(define (handle-request shp request) 
  (parameterize (($server shp)
                 ($request request)
                 ($pathinfo ($pathinfo))
                 ($chrome (shp-config-ref shp 'chrome))
                 ($status ($status))
                 ($content-type ($content-type)))
    (parameterize (($cookies (init-cookies!))
                   ($headers (convert-headers))
                   ($queries (convert-queries))
                   ($response-headers ($response-headers)))
      (with-handlers ((response/basic? identity)
                      (exn? 
                       (lambda (e) 
                         (display (format "error: ~a~n" e)(current-error-port))
                         (handle-with-default-handler 
                          shp 
                          (make-http-result 'internal-server-error (list e)))))
                      (http-result? 
                       (lambda (e) 
                         (handle-via-webcall-first-then-default shp e))))
        (load-required! shp)
        (handle-top-handler shp ($uri))))))

;; makes an shp handler for the servlet.
(define (make-shp-handler base 
                           #:default (default "index") 
                           #:required (required "/required")
                           #:topfilter (topfilter #f)
                           #:chrome (chrome #f)
                           #:htdocs (htdocs #f)) 
  (define (make-htdocs base htdocs) 
    (define (helper) 
      (if htdocs 
          (build-path base htdocs) 
          (build-path base 'up "file")))
    (let ((htdocs (helper))) 
      (if (directory-exists? htdocs)
          htdocs
          (error 'missing-htdocs-directory))))
  (make-shp base 
            (make-immutable-hash-registry `((default . ,default)
                                            (required . ,required) 
                                            (topfilter . ,topfilter)
                                            (chrome . ,chrome)
                                            (htdocs . ,(make-htdocs base htdocs))))
            handle-request 
            (make-immutable-hash-registry)
            handler-namespace))

(provide/contract 
 (make-shp-handler (->* (path-string?)
                        (#:default (or/c false/c path-string?)
                                   #:required (or/c false/c path-string?)
                                   #:topfilter (or/c false/c path-string?)
                                   #:chrome (or/c false/c #t path-string?)
                                   #:htdocs (or/c false/c path-string?))
                        shp?))
 )