#lang scheme/base

(require (for-syntax scheme/base)
         net/url
         scheme/contract
         srfi/26
         web-server/configuration/namespace
         web-server/dispatchers/filesystem-map
         web-server/http
         web-server/managers/lru
         web-server/managers/manager
         web-server/private/mime-types
         web-server/servlet/setup
         (prefix-in file:      web-server/dispatchers/dispatch-files)
         (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
         (prefix-in servlets:  web-server/dispatchers/dispatch-servlets)
         (planet untyped/mirrors:1)
         "defaults.ss"
         "run-server.ss")

;  (request -> response)
;  [#:port              natural]
;  [#:listen-ip         (U string #f)]
;  [#:htdocs-paths      (listof path)]
;  [#:mime-types-path   path]
;  [#:servlet-namespace (listof require-spec)]
;  [#:manager           manager]
; ->
; void
(define (go! start
             #:port              [port              8765]
             #:listen-ip         [listen-ip         "127.0.0.1"]
             #:htdocs-paths      [htdocs-paths      default-htdocs-paths]
             #:mime-types-path   [mime-types-path   default-mime-types-path]
             #:servlet-namespace [servlet-namespace default-servlet-namespace]
             #:manager           [manager           (make-instaservlet-manager)])
  
  ; connection request -> response
  (define htdocs-dispatcher
    (apply sequencer:make
           (map (lambda (path)
                  (file:make #:url->path       (make-url->path (path->complete-path path))
                             #:path->mime-type (make-path->mime-type (path->complete-path mime-types-path))))
                htdocs-paths)))
  
  ; connection request -> response
  (define servlet-dispatcher
    (let ([servlet-box    (box #f)]
          [make-namespace (make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace)])
      (servlets:make
       (lambda (url)
         (or (unbox servlet-box)
             (let ([servlet
                    (parameterize ([current-custodian (make-custodian)]
                                   [current-namespace (make-namespace)])
                      (if #;stateless? #f
                          (make-stateless.servlet (current-directory) start)
                          (make-v2.servlet (current-directory) manager start)))])
               (set-box! servlet-box servlet)
               servlet))))))
  
  ; connection request -> response
  (define (not-found-dispatcher connection request)
    (make-html-response (xml (html (body (p "Not found."))))))
  
  ; connection request -> response
  (define top-level-dispatcher
    (sequencer:make htdocs-dispatcher servlet-dispatcher not-found-dispatcher))
  
  (parameterize ([print-hash-table           #t]
                 [print-struct               #t]
                 [error-print-width          1024]
                 [error-print-context-length 50])
    (console-loop (cut run-server port listen-ip top-level-dispatcher))))

; Helpers ----------------------------------------

; [natural] -> manager
(define (make-instaservlet-manager [threshold (* 64 1024 1024)])
  (make-threshold-LRU-manager make-expired-response threshold))

; xml
(define stylesheet
  (xml (style (@ [type "text/css"])
              #<<ENDCSS
body { background: #eee; }
#container { border: 1px solid #aaa; background: #fff; width: 600px; margin: 50px auto; padding: 10px; }
h1 { font-family: verdana,arial,sans-serif; color: #500; margin-top: 0px; }
p { font-family: arial,sans-serif; }
ENDCSS
              )))

; request -> response
(define (make-not-found-response request)
  (make-html-response
   #:code    404
   #:message "Not found"
   #:seconds (current-seconds)
   (xml (html (head (title "404 not found")
                    ,stylesheet)
              (body (div (@ [id "container"])
                         (h1 "Controller not found")
                         (p "You visited the URL:")
                         (p (@ [class "example"])
                            (span (@ [class "argument"])
                                  "\"" ,(url->string (request-uri request)) "\""))
                         (p "Unfortunately, we could not find this page or resource on our site.")))))))

; request -> response
(define (make-expired-response request)
  (make-html-response
   #:code    200
   #:message "Page expired"
   #:seconds (current-seconds)
   (xml (html (head (title "Page expired")
                    ,stylesheet)
              (body (div (@ [id "container"])
                         (h1 "Page expired")
                         (p "Sorry, this page has expired, either due to changes to the "
                            "data stored here or due to a period of inactivity.")))))))

; Provide statements -----------------------------

(provide/contract
 [go!                       (->* ((-> request? response?))
                                 (#:port natural-number/c
                                         #:listen-ip         (or/c string? false/c)
                                         #:htdocs-paths      (listof path?)
                                         #:mime-types-path   path?
                                         #:servlet-namespace any/c
                                         #:manager           manager?)
                                 void?)]
 [make-instaservlet-manager (->* () (natural-number/c) manager?)]
 [make-not-found-response   (-> request? response?)]
 [make-expired-response     (-> request? response?)])