(require-extension test regex)

(load "../spiffy.scm")

(import spiffy regex)

(test-begin "spiffy")

(load "testlib")

(define noway "No way, Jose!")

(define counter 0)
(define root-counter 0)

(define (myscript-handler path)
  (write-logged-response)
  (display "script!" (response-port (current-response))))

(parameterize
    ((default-mime-type 'application/unknown)
     (handle-directory (lambda (p) (send-string/code 403 "Forbidden" "forbidden")))
     (file-extension-handlers `(("myscript" . ,myscript-handler)))
     (access-file "spiffy-access")
     (vhost-map
      `(("foohost" . , (lambda (continue)
                         (continue)))
        (,(regexp "testhost.*") . ,(lambda (continue)
                                     (continue)))
        ("redirect-host" . ,(lambda (continue)
                              (with-headers
                                  `((location ,(update-uri
                                                (request-uri (current-request))
                                                path: '(/ "move-along"))))
                                (lambda ()
                                  (send-status 303 "Moved")))))
        ("error-host" . ,(lambda (continue)
                           (error "This should give a 500 error")))
        ("unknown-length-host" . ,(lambda (continue)
                                    (write-logged-response)
                                    (let ((p (response-port (current-response))))
                                      (display "foo" p)
                                      (close-output-port p))))
        ("subdir-host" . ,(lambda (continue)
                            (parameterize ((root-path "./testweb/subdir"))
                              (continue)))))))
  (start-spiffy))

(define hello.txt (with-input-from-file "testweb/hello.txt" read-string))

(test-begin "vhost support")
(test "String match" `(200 ,hello.txt) (fetch-file "/hello.txt" "foohost"))
(test "String case insensitivity" `(200 ,hello.txt) (fetch-file "/hello.txt" "FOOHOST"))
(test "Regexp match" `(200 ,hello.txt) (fetch-file "/hello.txt" "testhost"))
(test "Regexp case sensitivity" `(404 ,NOT-FOUND) (fetch-file "/hello.txt" "TESTHOST"))
(test "Nonexistent host name" `(404 ,NOT-FOUND) (fetch-file "/hello.txt" "call-with-previous-continuation.org"))
(test "No host on HTTP/1.0 works" `(200 ,hello.txt) (fetch-file "/hello.txt" "foohost" send-headers: '()))
(test "No host on HTTP/1.1 gives error" 400 (car (fetch-file "/hello.txt" "foohost" send-headers: '() version: '(1 1) absolute-uri: #f)))
(test-end "vhost support")

(define chicken-logo.png (with-input-from-file "testweb/pics/chicken-logo.png" read-string))
(define lambda-chicken.gif (with-input-from-file "testweb/pics/lambda-chicken.gif" read-string))
(define index.html (with-input-from-file "testweb/index.html" read-string))
(define index-subdir (with-input-from-file "testweb/subdir/index.html" read-string))
(define index-subsubdir (with-input-from-file "testweb/subdir/subsubdir/index.html" read-string))
(define index-subdir-with-space (with-input-from-file "testweb/subdir with space/index.html" read-string))


(test-begin "static file serving")
(test "Nonexistant file" `(404 ,NOT-FOUND) (fetch-file "/bogus" "testhost"))
(test "Nonexistant file mimetype" 'text/html (header-value 'content-type (fetch-file "/bogus" "testhost" get-headers: #t)))
(test "Nonexistant file with extension" `(404 ,NOT-FOUND) (fetch-file "/bogus.gif" "testhost"))
(test "Nonexistant file with extension mimetype" 'text/html (header-value 'content-type (fetch-file "/bogus.gif" "testhost" get-headers: #t)))
(test "text/plain mimetype" 'text/plain (header-value 'content-type (fetch-file "/hello.txt" "testhost" get-headers: #t)))
(test "image/gif mimetype" 'image/gif (header-value 'content-type (fetch-file "/pics/lambda-chicken.gif" "testhost" get-headers: #t)))
(test "image/gif contents" `(200 ,lambda-chicken.gif) (fetch-file "/pics/lambda-chicken.gif" "testhost"))
(test "image/png mimetype" 'image/png (header-value 'content-type (fetch-file "/pics/chicken-logo.png" "testhost" get-headers: #t)))
(test "image/png contents" `(200 ,chicken-logo.png)  (fetch-file "/pics/chicken-logo.png" "testhost"))
(test "unknown mimetype" 'application/unknown (header-value 'content-type (fetch-file "/data" "testhost" get-headers: #t)))
(test "'Moved Permanently' on directory" 301 (car (fetch-file "/pics" "testhost")))
(test "location URI is absolute" "http://testhost:8080/pics/"
      (uri->string (header-value 'location (fetch-file "/pics" "testhost" get-headers: #t absolute-uri: #f))))
(test "directory listing denied" `(403 ,"forbidden") (fetch-file "/pics/" "testhost"))
(test-end "static file serving")

(test-begin "path normalization")
(test "index page redir" '(/ "subdir with space" "") (uri-path (header-value 'location (fetch-file "/subdir%20with%20space" "testhost" get-headers: #t))))
(test "index page redir preserves GET args" '((foo . "bar")) (uri-query (header-value 'location (fetch-file "/subdir%20with%20space?foo=bar" "testhost" get-headers: #t))))
(test "index page redir status" 301 (car (fetch-file "/subdir%20with%20space" "testhost")))
(test "index page" `(200 ,index-subdir-with-space) (fetch-file "/subdir%20with%20space/" "testhost"))
(test "break out of webroot fails" `(200 ,index-subdir) (fetch-file "/subdir/../../subdir/" "testhost"))
(test "index page in subdir vhost" `(200 ,index-subdir) (fetch-file "/" "subdir-host"))
(test "index page redir for subdir vhost" '(/ "subsubdir" "") (uri-path (header-value 'location (fetch-file "/subsubdir" "subdir-host" get-headers: #t))))
(test "index page redir status for subdir vhost" `301 (car (fetch-file "/subsubdir" "subdir-host")))
(test "index page in subdir for subdir vhost" `(200 ,index-subsubdir) (fetch-file "/subsubdir/" "subdir-host"))
(test "break out of vhost webroot gives index of root" `(200 ,index-subsubdir) (fetch-file "/subsubdir/../../subsubdir/" "subdir-host"))
(test "break out of vhost webroot fails" `(404 ,NOT-FOUND) (fetch-file "/../hello.txt" "subdir-host"))
(test "Null-terminated filename fails" `(404 ,NOT-FOUND) (fetch-file "/hello.txt%00xyz" "testhost"))
(test "encoded break out of vhost webroot fails" `(404 ,NOT-FOUND) (fetch-file "/%2e%2e%2fhello.txt" "subdir-host"))
(test-end "path normalization")

(test-begin "access files")
(set! root-counter 0)
(test "Webroot" `(200 ,index.html) (fetch-file "/" "testhost"))
(test "After webroot, root-counter is 1" 1 root-counter)
(set! counter 0)
(test "Two slashes" `(200 ,index-subdir) (fetch-file "/subdir//" "testhost"))
(test "After two slashes, counter is 1" 1 counter)
(test "After webroot and two slashes, root-counter is 2" 2 root-counter)
(test "Dir request" `(200 ,noway) (fetch-file "/secrets" "testhost")) ;; Access file applies on dir and all below
(test "File request in dir" `(200 ,noway) (fetch-file "/secrets/password.txt" "testhost"))
(test "Subdir request" `(200 ,noway) (fetch-file "/secrets/bank" "testhost"))
(test "File request in subdir" `(200 ,noway) (fetch-file "/secrets/bank/pin-code.txt" "testhost"))
(test-end "access files")

(test-begin "miscellaneous")
(test "custom extension handlers" `(200 "script!") (fetch-file "/test.myscript" "testhost"))
(test "redirect" 303 (car (fetch-file "/blah" "redirect-host")))
(test "redirect location" (uri-reference "http://redirect-host:8080/move-along") (header-value 'location (fetch-file "/blah" "redirect-host" get-headers: #t)))
(test "redirect for simulated proxy (other port)" (uri-reference "http://redirect-host:8081/move-along") (header-value 'location (fetch-file "/blah" "redirect-host" get-headers: #t send-headers: `((host ("redirect-host" . 8081))) absolute-uri: #f)))
(test "internal error" `(500 ,EXN) (fetch-file "/cause-error" "error-host"))
(test "Variable length (no content-length header)" `(200 "foo") (fetch-file "/whatever" "unknown-length-host"))
(test-assert "Variable length didn't cause error after response was sent" (not response-error?))
(test-end "miscellaneous")

(test-begin "Caching and other efficiency support")
(test-begin "If-Modified-Since/If-None-Match support")
(with-output-to-file "testweb/testfile.txt" (lambda () (display "Testing\n")))
(define timestamp (seconds->utc-time (current-seconds)))
(test "If-Modified-Since when not modified"
      `(304 "") ;; Should return 304 status, but also empty body
      (fetch-file "/testfile.txt" "testhost"
                  send-headers: `((host ("testhost" . ,(server-port)))
                                  (if-modified-since #(,timestamp ())))))
(define original-etag
  (header-value
   'etag
   (fetch-file "/testfile.txt" "testhost"
               get-headers: #t
               send-headers: `((host ("testhost" . ,(server-port)))))))
(test "If-None-Match when not modified"
      `(304 "") ;; Should return 304 status, but also empty body
      (fetch-file "/testfile.txt" "testhost"
                  send-headers: `((host ("testhost" . ,(server-port)))
                                  (if-none-match ,original-etag))))
(sleep 1)
(with-output-to-file "testweb/testfile.txt" (lambda () (display "Testing2\n")))
(test "If-Modified-Since when modified"
      `(200 "Testing2\n")
      (fetch-file "/testfile.txt" "testhost"
                  send-headers: `((host ("testhost" . ,(server-port)))
                                  (if-modified-since #(,timestamp ())))))
(test "If-None-Match when modified"
      `(200 "Testing2\n")
      (fetch-file "/testfile.txt" "testhost"
                  send-headers: `((host ("testhost" . ,(server-port)))
                                  (if-none-match ,original-etag))))
(let ((h (fetch-file "/testfile.txt" "testhost"
                     get-headers: #t
                     send-headers: `((host ("testhost" . ,(server-port)))
                                     (if-modified-since #(,timestamp ()))))))
  ;; RFC 2616, 10.3.5: Not modified must have date, unless clockless origin
  (test "Headers contain Date"
        #t
        (not (not (header-value 'date h))))
  ;; RFC 2616, 14.29:
  ;; "HTTP/1.1 servers SHOULD send Last-Modified whenever feasible"
  (test "Headers contain Last-Modified"
        (file-modification-time "testweb/testfile.txt")
        (utc-time->seconds (header-value 'last-modified h))))
(delete-file "testweb/testfile.txt") ;; Clean up after the tests
(test-end)
(test-begin "HEAD support")
(test "Regular response has no body"
      `(200 "")
      (fetch-file "/hello.txt" "testhost" method: 'HEAD))
(test "Status code responses have no body"
      `(303 "")
      (fetch-file "/blah" "redirect-host" method: 'HEAD))
(test-end)
(test-end)

(test-end)

(unless (zero? (test-failure-count)) (exit 1))