(require-extension test)

(load "../spiffy.scm")

(import spiffy regex)

(load "testlib")

(define noway "No way, Jose!")

(define counter 0)

(parameterize
    ((default-mime-type 'application/unknown)
     (handle-directory (lambda (p) (send-string/code 403 "Forbidden" "forbidden")))
     (access-file "spiffy-access")
     (vhost-map
      `(("foohost" . , (lambda (continue)
                         (continue)))
        (,(regexp "testhost.*") . ,(lambda (continue)
                                     (continue)))
        ("redirect-host" . ,(lambda (continue)
                              (with-headers `((location ,(uri-reference "/move-along")))
                                (lambda ()
                                  (send-status 303 "Moved")))))
        ("error-host" . ,(lambda (continue)
                           (error "This should give a 500 error")))
        ("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))))
(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))

(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" "") (uri-path (header-value 'location (fetch-file "/subdir" "testhost" get-headers: #t))))
(test "index page redir preserves GET args" '((foo . "bar")) (uri-query (header-value 'location (fetch-file "/subdir?foo=bar" "testhost" get-headers: #t))))
(test "index page redir status" 301 (car (fetch-file "/subdir" "testhost")))
(test "index page" `(200 ,index-subdir) (fetch-file "/subdir/" "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 "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! counter 0)
(test "Two slashes" `(200 ,index-subdir) (fetch-file "subdir//" "testhost"))
(test "After two slashes, counter is 1" 1 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 "redirect" 303 (car (fetch-file "blah" "redirect-host")))
(test "redirect location" (uri-reference "/move-along") (header-value 'location (fetch-file "blah" "redirect-host" get-headers: #t)))
(test "internal error" `(500 ,EXN) (fetch-file "cause-error" "error-host"))
(test-end "miscellaneous")