{-# LANGUAGE OverloadedStrings #-}

module Snap.Test.Tests
  ( tests
  ) where

------------------------------------------------------------------------------
import           Control.Applicative               (Applicative (..))
import           Control.Exception                 (ErrorCall (..), evaluate)
import           Control.Monad                     (MonadPlus (mzero), liftM)
import           Control.Monad.IO.Class            (liftIO)
import           Control.Monad.Trans               (lift)
import           Data.ByteString.Char8             (ByteString)
import qualified Data.ByteString.Char8             as S
import           Data.Functor                      (Functor (fmap, (<$)))
import qualified Data.Map                          as Map
import           Data.Maybe                        (fromJust, isJust)
import           Data.Text                         (Text)
import           Data.Time.Clock                   (getCurrentTime)
import           Prelude                           (Bool (True, False), IO, Int, Maybe (Just, Nothing), Monad (..), Ord (..), const, fail, fromIntegral, return, seq, show, ($), ($!), (*), (.))
import           Snap.Core                         (Cookie (Cookie, cookieExpires), Method (DELETE, GET, HEAD, Method, PATCH, POST, PUT), Request (rqContentLength, rqContextPath, rqIsSecure, rqMethod, rqParams, rqPathInfo, rqPostParams, rqQueryParams, rqQueryString, rqURI, rqVersion), Snap, expireCookie, extendTimeout, getCookie, getHeader, getParam, logError, readCookie, redirect, runSnap, terminateConnection, writeBS)
import           Snap.Internal.Http.Types          (Request (..), Response (rspCookies))
import qualified Snap.Internal.Http.Types          as T
import           Snap.Internal.Test.RequestBuilder (FileData (FileData), MultipartParam (Files, FormData), RequestBuilder, RequestType (DeleteRequest, GetRequest, MultipartPostRequest, RequestWithRawBody, UrlEncodedPostRequest), addCookies, addHeader, buildRequest, delete, evalHandler, get, postMultipart, postRaw, postUrlEncoded, put, requestToString, responseToString, runHandler, setContentType, setHeader, setHttpVersion, setQueryStringRaw, setRequestPath, setRequestType, setSecure)
import           Snap.Test                         (assert404, assertBodyContains, assertRedirect, assertRedirectTo, assertSuccess, getResponseBody)
import           Snap.Test.Common                  (coverShowInstance, expectExceptionH)
import           Snap.Util.FileUploads             (defaultUploadPolicy, handleMultipart, partContentType, partFieldName, partFileName)
import qualified System.IO.Streams                 as Streams
import           Test.Framework                    (Test)
import           Test.Framework.Providers.HUnit    (testCase)
import           Test.HUnit                        (assertBool, assertEqual)
import           Text.Regex.Posix                  ((=~))
------------------------------------------------------------------------------

------------------------------------------------------------------------------
tests :: [Test]
tests = [ testDefaultBuild
        , testRequestToString
        , testSetRequestType
        , testSetQueryString
        , testSetQueryStringRaw
        , testHeaders
        , testMisc
        , testMultipart
        , testPost
        , testFormEncoded
        , testToString
        , testAssert404
        , testAssertBodyContains
        , testAssertRedirect
        , testCookies
        , testTerminate
        , testTrivials
        , testHostName
        ]


------------------------------------------------------------------------------
testDefaultBuild :: Test
testDefaultBuild = testCase "test/requestBuilder/defaultBuild" $ do
    req <- buildRequest $ setRequestType GetRequest
    Streams.toList (rqBody req) >>= assertEqual "body" []
    assertEqual "pathInfo" "" $ rqPathInfo req
    assertEqual "ctx" "/" $ rqContextPath req
    assertEqual "uri" "/" $ rqURI req
    assertEqual "qs" "" $ rqQueryString req
    assertEqual "p1" Map.empty $ rqParams req
    assertEqual "p2" Map.empty $ rqQueryParams req
    assertEqual "p3" Map.empty $ rqPostParams req

------------------------------------------------------------------------------
testFormEncoded :: Test
testFormEncoded = testCase "test/requestBuilder/postFormEncoded" $ do
    req <- buildRequest $ postUrlEncoded "/foo/bar"
                        $ Map.fromList [("baz", ["qux"])]
    assertEqual "post params" [("baz", ["qux"])] $ Map.toList $ rqPostParams req
------------------------------------------------------------------------------
testSetRequestType :: Test
testSetRequestType = testCase "test/requestBuilder/setRequestType" $ do
    request1 <- buildRequest $ setRequestType GetRequest
    assertEqual "setRequestType/1" GET (rqMethod request1)

    request2 <- buildRequest $ setRequestType DeleteRequest
    assertEqual "setRequestType/2" DELETE (rqMethod request2)

    request3 <- buildRequest $ setRequestType $ RequestWithRawBody PUT "foo"
    assertEqual "setRequestType/3/Method" PUT (rqMethod request3)

    rqBody3  <- getRqBody request3
    assertEqual "setRequestType/3/Body" "foo" rqBody3

    request4 <- buildRequest $ setRequestType rt4
    assertEqual "setRequestType/4/Method" POST (rqMethod request4)
    -- will test correctness of multipart generation code in another test

    request5 <- buildRequest $ setRequestType $
                UrlEncodedPostRequest $ Map.fromList [("foo", ["foo"])]
    assertEqual "setRequestType/5/Method" POST (rqMethod request5)

    request6 <- buildRequest $ setRequestType $
                RequestWithRawBody (Method "MOVE") "foo"
    assertEqual "setRequestType/6/Method" (Method "MOVE") (rqMethod request6)

    request7 <- buildRequest $ setRequestType $ RequestWithRawBody PATCH "bar"
    assertEqual "setRequestType/7/Method" PATCH (rqMethod request7)

    request8 <- buildRequest $ setRequestType $ RequestWithRawBody HEAD ""
    assertEqual "setRequestType/8/Method" HEAD (rqMethod request8)

  where
    rt4 = MultipartPostRequest [ ("foo", FormData ["foo"])
                               , ("bar", Files [fd4])
                               ]

    fd4 = FileData "bar.txt" "text/plain" "bar"


------------------------------------------------------------------------------
testSetQueryString :: Test
testSetQueryString = testCase "test/requestBuilder/testSetQueryString" $ do
    request <- buildRequest $ get "/" params
    assertEqual "setQueryString" params $ rqParams request
    assertEqual "queryString" "bar=bar&foo=foo&foo=foo2" $
                rqQueryString request

  where
    params = Map.fromList [ ("foo", ["foo", "foo2"])
                          , ("bar", ["bar"]) ]


------------------------------------------------------------------------------
testSetQueryStringRaw :: Test
testSetQueryStringRaw = testCase "test/requestBuilder/testSetQueryStringRaw" $ do
    request <- buildRequest $ do
                   postUrlEncoded "/" $ Map.fromList [("foo", ["foo0"])]
                   addCookies [c1, c2]
                   setQueryStringRaw "foo=foo&foo=foo2&bar=bar"
    assertEqual "setQueryStringRaw" params $ rqParams request
    assertEqual "cookie" (Just "k=v; k2=v2") $ getHeader "cookie" request

  where
    c1     = Cookie "k" "v" Nothing Nothing Nothing False False
    c2     = Cookie "k2" "v2" Nothing Nothing Nothing False False
    params = Map.fromList [ ("foo", ["foo0", "foo", "foo2"])
                          , ("bar", ["bar"]) ]


------------------------------------------------------------------------------
testHeaders :: Test
testHeaders = testCase "test/requestBuilder/testHeaders" $ do
    request <- buildRequest $ do
                   get "/" Map.empty
                   setHeader "foo" "foo"
                   addHeader "bar" "bar"
                   addHeader "bar" "bar2"
                   setContentType "image/gif"  -- this should get deleted
    assertEqual "setHeader" (Just "foo") $ getHeader "foo" request
    assertEqual "addHeader" (Just "bar,bar2") $ T.getHeader "bar" request
    assertEqual "contentType" Nothing $ T.getHeader "Content-Type" request
    assertEqual "contentLength" Nothing $ rqContentLength request
    assertEqual "contentLengthHdr" Nothing $ getHeader "Content-Length" request

    request2 <- buildRequest $ put "/" "text/zzz" "zzz"
    assertEqual "contentType2" (Just "text/zzz") $
                T.getHeader "Content-Type" request2
    assertEqual "contentLength" (Just 3) $ rqContentLength request2
    assertEqual "contentLengthHdr" (Just "3") $
                getHeader "Content-Length" request2


------------------------------------------------------------------------------
testMisc :: Test
testMisc = testCase "test/requestBuilder/testMisc" $ do
    request <- buildRequest $ do
        get "/" Map.empty
        setSecure True
        setRequestPath "/foo/bar"

    assertEqual "secure" True $ rqIsSecure request
    assertEqual "rqPathInfo" "foo/bar" $ rqPathInfo request
    assertEqual "rqURI" "/foo/bar" $ rqURI request
    assertEqual "rqContextPath" "/" $ rqContextPath request
    assertEqual "rqVersion" (1,1) $ rqVersion request

    body <- getRqBody request
    assertEqual "body" "" body

    request2 <- buildRequest $ do
        postRaw "/" "text/zzz" "zzz"
        setHttpVersion (1,0)

    body2 <- getRqBody request2
    assertEqual "body2" "zzz" body2

    assertEqual "contentType2" (Just "text/zzz") $
                T.getHeader "Content-Type" request2
    assertEqual "postRaw" POST $ rqMethod request2
    assertEqual "rqVersion2" (1,0) $ rqVersion request2

    request3 <- buildRequest $ do
        delete "/" Map.empty
        setSecure True
        setRequestPath "/foo/bar"

    assertEqual "secure" True $ rqIsSecure request3
    assertEqual "method" DELETE $ rqMethod request3
    assertEqual "rqPathInfo" "foo/bar" $ rqPathInfo request3
    assertEqual "rqURI" "/foo/bar" $ rqURI request3
    assertEqual "rqContextPath" "/" $ rqContextPath request3
    assertEqual "rqVersion" (1,1) $ rqVersion request3


------------------------------------------------------------------------------
testMultipart :: Test
testMultipart = testCase "test/requestBuilder/testMultipart" $ do
    request0        <- buildRequest rq
    (request,rbody) <- peekRqBody request0
    assertEqual "content-length" (Just (fromIntegral $ S.length rbody)) $
                rqContentLength request

    (_,response) <- runSnap handler (const $ return $! ())
                                    (const $ return $! ())
                                    request
    body     <- getResponseBody response
    assertEqual "body" "OK" body

  where
    partHandler pinfo stream = do
        let field = partFieldName pinfo
        let fn    = partFileName pinfo
        let ct    = partContentType pinfo
        body <- liftM S.concat $ Streams.toList stream
        return (field, fn, ct, body)

    expectedParts = [ ("bar", Just "bar1.txt", "text/plain", "bar")
                    , ("bar", Just "bar2.txt", "text/zzz", "bar2")
                    , ("baz", Just "baz.gif", "text/gif", "baz") ]

    handler = do
        parts <- handleMultipart defaultUploadPolicy partHandler
        fooParam <- getParam "foo"
        liftIO $ assertEqual "param" (Just "oof") fooParam

        quuxParams <- getParam "quux"
        liftIO $ assertEqual "quux" (Just "quux1 quux2") quuxParams
        liftIO $ assertEqual "parts" expectedParts parts
        writeBS "OK"

    rq = postMultipart "/" rt

    rt = [ ("foo", FormData ["oof"])
         , ("bar", Files [fb1, fb2])
         , ("baz", Files [fz])
         , ("zzz", Files [])
         , ("zz0", FormData [])
         , ("quux", FormData ["quux1", "quux2"])
         ]

    fb1 = FileData "bar1.txt" "text/plain" "bar"
    fb2 = FileData "bar2.txt" "text/zzz" "bar2"
    fz = FileData "baz.gif" "text/gif" "baz"


------------------------------------------------------------------------------
testPost :: Test
testPost = testCase "test/requestBuilder/testPost" $ do
    request <- buildRequest $ do
        postUrlEncoded "/" $ Map.fromList [("foo", ["foo1", "foo2"])]

    body <- getRqBody request
    assertEqual "body" "foo=foo1&foo=foo2" body
    assertEqual "len" (Just (fromIntegral $ S.length body))
                      (rqContentLength request)
    assertEqual "contentType" (Just "application/x-www-form-urlencoded") $
                getHeader "Content-Type" request


------------------------------------------------------------------------------
testToString :: Test
testToString = testCase "test/requestBuilder/testToString" $ do
    rsp  <- runHandler rq h
    http <- responseToString rsp
    body <- getResponseBody rsp
    out2 <- evalHandler rq h

    assertSuccess rsp
    assertEqual "Close" (Just "close") $ getHeader "connection" rsp
    assertEqual "HTTP body" "zzz" body
    assertBool "HTTP header" $ http =~ headRE
    assertBool "HTTP date"   $ http =~ dateRE
    assertEqual "monadic result" 42 out2
  where
    rq     = do postRaw "/" "text/zzz" "zzz"
                setHttpVersion (1,0)
    h      = do writeBS "zzz"
                logError "zzz"
                extendTimeout 5
                return (42 :: Int)
    headRE = "HTTP/1.1 200 OK" :: ByteString
    dateRE = S.concat [ "date: [a-zA-Z]+, [0-9]+ [a-zA-Z]+ "
                      , "[0-9]+ [0-9]+:[0-9]+:[0-9]+ GMT"
                      ]


------------------------------------------------------------------------------
testRequestToString :: Test
testRequestToString = testCase "test/requestBuilder/reqToString" $ do
    req1 <- buildRequest $ setRequestType GetRequest
    s1   <- requestToString req1
    assertBool "HTTP header" $ s1 =~ headRE

    req2 <- buildRequest $ do postRaw "/" "text/zzz" "zzz"
                              setHttpVersion (1,0)
    s2   <- requestToString req2
    assertBool "HTTP header2" $ s2 =~ postHeadRE
    assertBool "HTTP cl" $ s2 =~ ("content-length: 3" :: ByteString)

    req3 <- buildRequest $ do postRaw "/" "text/zzz" "zzz"
                              setHeader "transfer-encoding" "chunked"
    s3   <- requestToString req3
    assertBool "HTTP chunked" $ "3\r\nzzz\r\n0\r\n\r\n" `S.isSuffixOf` s3

  where
    headRE = "^GET / HTTP/1.1\r\n" :: ByteString
    postHeadRE = "^POST / HTTP/1.0\r\n" :: ByteString


------------------------------------------------------------------------------
testAssert404 :: Test
testAssert404 = testCase "test/requestBuilder/testAssert404" $ do
    rsp <- runHandler (get "/" Map.empty) mzero
    assert404 rsp
    expectExceptionH $ assertSuccess rsp
    expectExceptionH $ assertBodyContains "fjlkdja" rsp
    expectExceptionH $ assertRedirectTo "/zzzzz" rsp
    expectExceptionH $ assertRedirect rsp

    rsp2 <- runHandler (get "/" Map.empty) (return ())
    assertSuccess rsp2
    expectExceptionH $ assert404 rsp2



------------------------------------------------------------------------------
testAssertBodyContains :: Test
testAssertBodyContains =
    testCase "test/requestBuilder/testAssertBodyContains" $ do
        rsp <- runHandler (get "/" Map.empty) $ do
                   writeBS "RESPONSE IS OK"
        assertBodyContains "NSE IS" rsp


------------------------------------------------------------------------------
testAssertRedirect :: Test
testAssertRedirect = testCase "test/requestBuilder/testAssertRedirect" $ do
    rsp <- runHandler (get "/" Map.empty) $ redirect "/bar"
    assertRedirectTo "/bar" rsp
    assertRedirect rsp
    expectExceptionH $ assertRedirectTo "/zzzz" rsp


------------------------------------------------------------------------------
testCookies :: Test
testCookies = testCase "test/requestBuilder/cookies" $ do
    evalHandler (get "/" Map.empty) (getCookie "foo")
        >>= assertEqual "cookie1" Nothing
    evalHandler (get "/" Map.empty >> addCookies [c1]) (getCookie "foo")
        >>= assertEqual "cookie2" (Just c1)
    evalHandler (get "/" Map.empty >> addCookies [c1]) (readCookie "foo")
        >>= assertEqual "cookie3" ("bar" :: Text)
    expectExceptionH $
        evalHandler (get "/" Map.empty >> addCookies [c2])
                    ((readCookie "foo") :: Snap Int)
    expectExceptionH $
        evalHandler (get "/" Map.empty >> addCookies [c2])
                    ((readCookie "bar") :: Snap Int)
    rsp <- runHandler (get "/" Map.empty) expire

    let h = Map.lookup "foo" (rspCookies rsp)
    assertBool "isJust" (isJust h)

    now <- getCurrentTime
    let tm = fromJust $ cookieExpires $ fromJust h
    assertBool "time" (tm < now)
    return $! show tm `seq` ()

    -- FIXME(greg): the following test currently fails because we're rendering
    -- the set-cookie headers in the server instead of in fixupResponse where
    -- it should be happening

    -- let h = getHeader "set-cookie" rsp
    -- assertBool "isJust" (isJust h)
    -- let (Just cookie) = h
    -- assertEqual "cookie" "" cookie
  where
    c1 = Cookie "foo" "bar" Nothing Nothing Nothing False False
    c2 = Cookie "foo" "zzzzz" Nothing Nothing Nothing False False

    expire = expireCookie c1


------------------------------------------------------------------------------
testTerminate :: Test
testTerminate = testCase "test/requestBuilder/terminate" $
                expectExceptionH $
                evalHandler (return ()) (terminateConnection $ ErrorCall "foo")


------------------------------------------------------------------------------
testTrivials :: Test
testTrivials = testCase "test/requestBuilder/trivials" $ do
    coverShowInstance (FormData [])
    coverShowInstance (Files [])
    coverShowInstance (FileData "" "" "")
    coverShowInstance GetRequest
    z <- buildRequest $ do
             (() <$ (pure () <* rb *> rb2)) >>= lift . evaluate
             x <- fmap (*4) (return (3 :: Int))
             lift $ assertEqual "fmap" 12 x

    expectExceptionH $ buildRequest $ fail "foo"
    z `seq` return ()

  where
    rb = (return ()) :: (Functor m, Monad m, Applicative m) => RequestBuilder m ()
    rb2 = (pure ()) :: (Functor m, Monad m, Applicative m) => RequestBuilder m ()


------------------------------------------------------------------------------
testHostName :: Test
testHostName = testCase "test/requestBuilder/hostName" $ do
    request <- buildRequest $ do
        get "/" Map.empty
        setHeader "Host" "just.an.example.com"
    assertEqual "HostName" "just.an.example.com" $ rqHostName request
    assertEqual "Host header" (Just "just.an.example.com") $ getHeader "host" request


------------------------------------------------------------------------------
getRqBody :: Request -> IO ByteString
getRqBody = liftM S.concat . Streams.toList . rqBody


peekRqBody :: Request -> IO (Request, ByteString)
peekRqBody rq = do
    l <- Streams.toList $ rqBody rq
    b <- Streams.fromList l

    return (rq { rqBody = b }, S.concat l)