; Derived from plai/web/server, which was based on an older version of this
; Also derived from planet/untyped/instaservlet
#lang racket/base
(require racket/contract
         racket/list
         racket/serialize
         racket/runtime-path
         (only-in racket/tcp listen-port-number?)
         (for-syntax racket/base))
(require net/url
         web-server/managers/lru
         web-server/managers/manager
         web-server/configuration/namespace
         web-server/http
         web-server/stuffers
         web-server/configuration/responders
         web-server/private/mime-types
         web-server/servlet/setup
         web-server/servlet/servlet-structs
         web-server/servlet-dispatch
         (prefix-in lift: web-server/dispatchers/dispatch-lift)
         (prefix-in fsmap: web-server/dispatchers/filesystem-map)
         (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
         (prefix-in files: web-server/dispatchers/dispatch-files)
         (prefix-in filter: web-server/dispatchers/dispatch-filter)
         (prefix-in servlets: web-server/dispatchers/dispatch-servlets)
         (prefix-in log: web-server/dispatchers/dispatch-log))

(define (quit-server sema)
  (lift:make
   (lambda (request)
     (semaphore-post sema)
     (response/xexpr
      `(html (head (title "Server Stopped")
                   (link ([rel "stylesheet"] [href "/error.css"])))
             (body (div ([class "section"])
                        (div ([class "title"]) "Server Stopped")
                        (p "Return to DrRacket."))))))))

(define-runtime-path default-web-root "default-web-root")

(provide/contract
 [serve/servlet (((request? . -> . can-be-response?))
                 (#:connection-close? boolean?
                  #:command-line? boolean?
                  #:launch-browser? boolean?
                  #:quit? boolean?
                  #:banner? boolean?
                  #:listen-ip (or/c false/c string?)
                  #:port listen-port-number?
                  #:max-waiting exact-nonnegative-integer?
                  #:ssl? boolean?
                  #:ssl-cert (or/c false/c path-string?)
                  #:ssl-key (or/c false/c path-string?)
                  #:manager manager?
                  #:servlet-namespace (listof module-path?)
                  #:server-root-path path-string?
                  #:stateless? boolean?
                  #:stuffer (stuffer/c serializable? bytes?)
                  #:extra-files-paths (listof path-string?)
                  #:servlets-root path-string?
                  #:servlet-current-directory path-string?
                  #:file-not-found-responder (request? . -> . can-be-response?)
                  #:servlet-loading-responder (url? any/c . -> . can-be-response?)
                  #:servlet-responder (url? any/c . -> . can-be-response?)
                  #:mime-types-path path-string?
                  #:servlet-path string?
                  #:servlet-regexp regexp?
                  #:log-file (or/c false/c path-string?)
                  #:log-format (or/c log:log-format/c log:format-req/c))
                 . ->* .
                 void)])

;; utility for conveniently chaining dispatchers
(define (dispatcher-sequence . dispatchers)
  (let loop ([ds dispatchers] [r '()])
    (cond [(null? ds) (apply sequencer:make (reverse r))]
          [(not (car ds))   (loop (cdr ds) r)]
          [(list? (car ds)) (loop (append (car ds) (cdr ds)) r)]
          [else (loop (cdr ds) (cons (car ds) r))])))

(define (serve/servlet
         start
         #:connection-close?
         [connection-close? #f]
         #:command-line?
         [command-line? #f]
         #:launch-browser?
         [launch-browser? (not command-line?)]
         #:quit?
         [quit? (not command-line?)]
         #:banner?
         [banner? (not command-line?)]

         #:listen-ip
         [listen-ip "127.0.0.1"]
         #:port
         [the-port 8000]         
         #:max-waiting
         [max-waiting 511]

         #:manager
         [manager
          (make-threshold-LRU-manager
           (lambda (request)
             (response/xexpr
              `(html (head (title "Page Has Expired."))
                     (body (p "Sorry, this page has expired. Please go back.")))))
           (* 128 1024 1024))]

         #:servlet-path
         [servlet-path "/servlets/standalone.rkt"]
         #:servlet-regexp
         [servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))]
         #:stateless?
         [stateless? #f]
         #:stuffer
         [stuffer default-stuffer]

         #:servlet-namespace
         [servlet-namespace empty]
         #:server-root-path
         [server-root-path default-web-root]
         #:extra-files-paths
         [extra-files-paths (list (build-path server-root-path "htdocs"))]
         #:servlets-root
         [servlets-root (build-path server-root-path "htdocs")]
         #:servlet-current-directory
         [servlet-current-directory servlets-root]
         #:file-not-found-responder
         [file-not-found-responder
          (gen-file-not-found-responder
           (build-path server-root-path "conf" "not-found.html"))]
         #:servlet-loading-responder
         [responders-servlet-loading servlet-loading-responder]
         #:servlet-responder 
         [responders-servlet servlet-error-responder]

         #:mime-types-path
         [mime-types-path (let ([p (build-path server-root-path "mime.types")])
                            (if (file-exists? p)
                              p
                              (build-path default-web-root "mime.types")))]
         
         #:ssl?
         [ssl? #f]
         #:ssl-cert
         [ssl-cert (and ssl? (build-path server-root-path "server-cert.pem"))]
         #:ssl-key
         [ssl-key (and ssl? (build-path server-root-path "private-key.pem"))]

         #:log-file
         [log-file #f]
         #:log-format
         [log-format 'apache-default])
  (define (dispatcher sema)
    (dispatcher-sequence
     (and log-file (log:make #:format 
                             (if (symbol? log-format)
                                 (log:log-format->format log-format)
                                 log-format)
                             #:log-path log-file))
     (and quit? (filter:make #rx"^/quit$" (quit-server sema)))
     (dispatch/servlet 
      start
      #:regexp servlet-regexp
      #:stateless? stateless?
      #:stuffer stuffer
      #:current-directory servlet-current-directory
      #:manager manager
      #:responders-servlet-loading
      responders-servlet-loading
      #:responders-servlet 
      responders-servlet)
     (let-values ([(clear-cache! url->servlet)
                   (servlets:make-cached-url->servlet
                    (fsmap:filter-url->path
                     #rx"\\.(ss|scm|rkt|rktd)$"
                     (fsmap:make-url->valid-path
                      (fsmap:make-url->path servlets-root)))
                    (make-default-path->servlet
                     #:make-servlet-namespace 
                     (make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace)))])
       (servlets:make url->servlet))
     (map (lambda (extra-files-path)
            (files:make
             #:url->path (fsmap:make-url->path extra-files-path)
             #:path->mime-type (make-path->mime-type mime-types-path)
             #:indices (list "index.html" "index.htm")))
          extra-files-paths)
     (files:make
      #:url->path (fsmap:make-url->path (build-path server-root-path "htdocs"))
      #:path->mime-type (make-path->mime-type mime-types-path)
      #:indices (list "index.html" "index.htm"))
     (lift:make (compose any->response file-not-found-responder))))
  (serve/launch/wait
   dispatcher  
   #:connection-close? connection-close?
   #:launch-path (if launch-browser? servlet-path #f) 
   #:banner? banner?   
   #:listen-ip listen-ip
   #:port the-port
   #:max-waiting max-waiting
   #:ssl-cert ssl-cert
   #:ssl-key ssl-key))
