#lang scheme/base
(require mzlib/plt-match
         scheme/contract)
(require "dispatch.ss"
         "../private/web-server-structs.ss"
         "../private/connection-manager.ss"
         "../private/response.ss"
         "../private/request-structs.ss"
         "../private/response-structs.ss"
         "../servlet/web-cells.ss"
         "../servlet/web.ss"
         net/url
         "../dispatchers/filesystem-map.ss"
         "../configuration/responders.ss"
         "../configuration/namespace.ss"
         "../managers/manager.ss"
         "../managers/timeouts.ss"
         "../private/servlet.ss"
         "../private/cache-table.ss"
         "../private/util.ss")  
(provide/contract
 [interface-version dispatcher-interface-version?]
 [make (->* ((box/c cache-table?)
             #:url->path url-path?)
            (#:make-servlet-namespace make-servlet-namespace?
                                      #:responders-servlet-loading (url? any/c . -> . response?)
                                      #:responders-servlet (url? any/c . -> . response?)
                                      #:timeouts-default-servlet number?)
            (values (-> void)
                    dispatcher?))])

(define interface-version 'v1)
(define (make config:scripts 
              #:url->path url->path
              #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)]
              #:responders-servlet-loading [responders-servlet-loading servlet-loading-responder]
              #:responders-servlet [responders-servlet (gen-servlet-responder "servlet-error.html")]
              #:timeouts-default-servlet [timeouts-default-servlet 30])
  
  ;; servlet-content-producer: connection request -> void
  (define (servlet-content-producer conn req)
    (define meth (request-method req))
    (define uri (request-uri req))
    (cond
      [(continuation-url? uri)
       => (match-lambda
            [(list instance-id k-id salt)
             (invoke-servlet-continuation conn req instance-id k-id salt)])]
      [else
       (servlet-content-producer/path conn req uri)]))
  
  ;; servlet-content-producer/path: connection request url -> void
  (define (servlet-content-producer/path conn req uri)
    (define response
      (with-handlers ([exn:fail:filesystem:exists:servlet?
                       (lambda (the-exn) (next-dispatcher))]
                      [(lambda (x) #t)
                       (lambda (the-exn) (responders-servlet-loading uri the-exn))])
        (call-with-continuation-prompt
         (lambda ()
           ; Create the session frame
           (with-frame
            (define instance-custodian (make-servlet-custodian))
            (define-values (servlet-path _)
              (with-handlers
                  ([void (lambda (e)
                           (raise (make-exn:fail:filesystem:exists:servlet
                                   (exn-message e)
                                   (exn-continuation-marks e))))])
                (url->path uri)))
            (parameterize ([current-directory (directory-part servlet-path)]
                           [current-custodian instance-custodian]
                           [exit-handler
                            (lambda _
                              (kill-connection! conn)
                              (custodian-shutdown-all instance-custodian))])
              ;; any resources (e.g. threads) created when the
              ;; servlet is loaded should be within the dynamic
              ;; extent of the servlet custodian
              (define the-servlet (cached-load servlet-path))
              (parameterize ([current-servlet the-servlet]
                             [current-namespace (servlet-namespace the-servlet)])
                (define manager (servlet-manager the-servlet))
                (parameterize ([current-execution-context (make-execution-context req)])
                  (define instance-id ((manager-create-instance manager) (exit-handler)))
                  (parameterize ([current-servlet-instance-id instance-id])
                    (with-handlers ([(lambda (x) #t)
                                     (lambda (exn)
                                       (responders-servlet
                                        (request-uri req)
                                        exn))])
                      ((servlet-handler the-servlet) req))))))))
         servlet-prompt)))
    (output-response conn response))
  
  ;; default-server-instance-expiration-handler : (request -> response)
  (define (default-servlet-instance-expiration-handler req)
    (next-dispatcher))
  
  (define (invoke-servlet-continuation conn req instance-id k-id salt)
    (define uri (request-uri req))
    (define-values (servlet-path _) (url->path uri))
    (define the-servlet (cached-load servlet-path))
    (define manager (servlet-manager the-servlet))
    (define response
      (parameterize ([current-servlet the-servlet]
                     [current-directory (directory-part servlet-path)]
                     [current-servlet-instance-id instance-id]
                     [current-custodian (servlet-custodian the-servlet)]
                     [current-namespace (servlet-namespace the-servlet)]
                     [exit-handler
                      (lambda _
                        (kill-connection! conn)
                        (custodian-shutdown-all (servlet-custodian the-servlet)))])
        (with-handlers ([exn:fail:servlet-manager:no-instance?
                         (lambda (the-exn)
                           ((exn:fail:servlet-manager:no-instance-expiration-handler the-exn) req))]
                        [exn:fail:servlet-manager:no-continuation?
                         (lambda (the-exn)
                           ((exn:fail:servlet-manager:no-continuation-expiration-handler the-exn) req))]
                        [exn:fail:servlet:instance?
                         (lambda (the-exn)
                           (default-servlet-instance-expiration-handler req))])
          (parameterize ([current-execution-context (make-execution-context req)])
            (call-with-continuation-prompt
             (lambda ()
               (define kcb ((manager-continuation-lookup manager) instance-id k-id salt))
               ((custodian-box-value kcb) req))
             servlet-prompt)))))
    (output-response conn response))
  
  ;; cached-load : path -> script, namespace
  (define (cached-load servlet-path)
    (cache-table-lookup! (unbox config:scripts)
                         (string->symbol (path->string servlet-path))
                         (lambda () (load-servlet/path servlet-path))))
  
  ;; exn:i/o:filesystem:servlet-not-found =
  ;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym)
  (define-struct (exn:fail:filesystem:exists:servlet
                  exn:fail:filesystem:exists) ())
  
  (define (v0.response->v1.lambda response response-path)
    (define go
      (box
       (lambda ()
         (set-box! go (lambda () (load/use-compiled response-path)))
         response)))
    (lambda (initial-request)
      ((unbox go))))
  
  (define (v1.module->v1.lambda timeout start)
    (lambda (initial-request)
      (adjust-timeout! timeout)
      (start initial-request)))
  
  ;; load-servlet/path path -> servlet
  (define (load-servlet/path a-path)
    (parameterize ([current-namespace (make-servlet-namespace
                                       #:additional-specs
                                       '(web-server/servlet
                                         (lib "servlet.ss" "web-server" "private")
                                         (lib "web.ss" "web-server" "servlet")
                                         (lib "web-cells.ss" "web-server" "servlet")))]
                   [current-custodian (make-servlet-custodian)])
      ; XXX load/use-compiled breaks errortrace
      (define s (load/use-compiled a-path))
      (cond
        [(void? s)
         (let* ([module-name `(file ,(path->string a-path))]
                [version (dynamic-require module-name 'interface-version)])
           (case version
             [(v1)
              (let ([timeout (dynamic-require module-name 'timeout)]
                    [start (dynamic-require module-name 'start)])
                (make-servlet (current-custodian)
                              (current-namespace)
                              (create-timeout-manager
                               default-servlet-instance-expiration-handler
                               timeout
                               timeout)
                              (v1.module->v1.lambda timeout start)))]
             [(v2)
              (let ([start (dynamic-require module-name 'start)]
                    [manager (dynamic-require module-name 'manager)])
                (make-servlet (current-custodian)
                              (current-namespace)
                              manager
                              start))]
             [else
              (error 'load-servlet/path "unknown servlet version ~e, must be 'v1 or 'v2" version)]))]
        [(response? s)
         (make-servlet (current-custodian)
                       (current-namespace)
                       (create-timeout-manager
                        default-servlet-instance-expiration-handler
                        timeouts-default-servlet
                        timeouts-default-servlet)
                       (v0.response->v1.lambda s a-path))]
        [else
         (error 'load-servlet/path "Loading ~e produced ~n~e~n instead of either (1) a response or (2) nothing and exports 'interface-version" a-path s)])))
  
  (values (lambda ()
            ;; XXX - this is broken - only out of date or specifically mentioned scripts should be flushed.  This destroys persistent state!
            (cache-table-clear! (unbox config:scripts)))
          servlet-content-producer))
