{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}

-- Deprecations warnings turned off due to ErrorT deprecation
--
-- It's a pain that this setting is per-module, because we might end up hiding
-- deprecation warnings that we want to see. TODO: move any code that emits
-- these warnings to isolated modules.

{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE Rank2Types          #-}
{-# LANGUAGE ScopedTypeVariables #-}

------------------------------------------------------------------------------
module Snap.Core.Tests ( tests ) where
------------------------------------------------------------------------------
import           Control.Applicative                  (Alternative ((<|>)), Applicative ((<*>), pure), (<$>))
import           Control.Concurrent.MVar              (newEmptyMVar, putMVar, takeMVar)
import           Control.DeepSeq                      (deepseq)
import           Control.Exception.Lifted             (ErrorCall (..), Exception, SomeException (..), catch, fromException, mask, throwIO, try)
import           Control.Monad                        (Functor (fmap), Monad ((>>), (>>=), return), MonadPlus (mplus, mzero), forM_, liftM, void)
import           Control.Monad.Base                   (MonadBase (liftBase))
import           Control.Monad.IO.Class               (liftIO)
#if !MIN_VERSION_transformers(0,6,0)
import           Control.Monad.Trans.Error            (ErrorT (runErrorT))
#endif
import           Data.ByteString.Builder              (byteString)
#if MIN_VERSION_transformers(0,4,0)
import           Control.Monad.Trans.Except           (runExceptT)
#endif
#if !MIN_VERSION_transformers(0,6,0)
import           Control.Monad.Trans.List             (ListT (runListT))
#endif
import           Control.Monad.Trans.Reader           (ReaderT (runReaderT))
import qualified Control.Monad.Trans.RWS.Lazy         as LRWS (RWST (runRWST))
import           Control.Monad.Trans.RWS.Strict       (RWST (runRWST))
import qualified Control.Monad.Trans.State.Lazy       as LState (evalStateT)
import           Control.Monad.Trans.State.Strict     (evalStateT)
import qualified Control.Monad.Trans.Writer.Lazy      as LWriter (WriterT (runWriterT))
import           Control.Monad.Trans.Writer.Strict    (WriterT (runWriterT))
import           Control.Parallel.Strategies          (rdeepseq, using)
import           Data.ByteString.Char8                (ByteString)
import qualified Data.ByteString.Char8                as S (length, pack, replicate)
import qualified Data.ByteString.Lazy.Char8           as L (ByteString, fromChunks, isPrefixOf)
import qualified Data.IntMap                          as IM (toList)
import           Data.IORef                           (newIORef, readIORef, writeIORef)
import qualified Data.Map                             as Map (empty, fromList)
import           Data.Maybe                           (isJust)
import           Data.Monoid                          (mappend)
import           Data.Text                            (Text)
import qualified Data.Text.Encoding                   as T (encodeUtf8)
import           Data.Text.Lazy                       ()
import           Prelude                              (Bool (..), Either (..), Enum (..), Eq (..), IO, Int, Maybe (Just, Nothing), Num (..), Show (..), String, const, either, fail, flip, id, map, maybe, not, seq, undefined, ($), ($!), (&&), (++), (.))
import           Snap.Internal.Core                   (EscapeSnap (..), MonadSnap (..), NoHandlerException (NoHandlerException), Snap, addToOutput, bracketSnap, catchFinishWith, dir, escapeHttp, evalSnap, finishWith, getParam, getParams, getPostParam, getPostParams, getQueryParam, getQueryParams, getRequest, getResponse, getsResponse, ifTop, ipHeaderFilter, localRequest, logError, method, methods, modifyResponse, pass, path, pathArg, putRequest, putResponse, readRequestBody, redirect, redirect', runRequestBody, runSnap, setTimeout, terminateConnection, transformRequestBody, updateContextPath, withRequest, withResponse, writeBS, writeLBS, writeLazyText, writeText)
import           Snap.Internal.Http.Types             (Cookie (Cookie), Method (..), Request (rqBody, rqClientAddr, rqContextPath, rqIsSecure, rqURI), Response (rspContentLength, rspStatus, rspStatusReason, rspTransformingRqBody), addHeader, deleteHeader, emptyResponse, getHeader, rqRemoteAddr, setContentLength, setHeader, setResponseCode, setResponseStatus, statusReasonMap)
import           Snap.Internal.Parsing                (urlDecode, urlEncode)
import qualified Snap.Test                            as Test (RequestType (RequestWithRawBody), buildRequest, evalHandler, get, getResponseBody, postRaw, runHandler, setRequestType)
import           Snap.Test.Common                     (coverEqInstance, coverOrdInstance, coverReadInstance, coverShowInstance, coverTypeableInstance, expectExceptionH, forceSameType, waitabit)
import           System.IO.Streams                    (InputStream)
import qualified System.IO.Streams                    as Streams (fromList, makeInputStream, nullInput, nullOutput, read, throwIfTooSlow, toList, write)
import           Test.Framework                       (Test)
import           Test.Framework.Providers.HUnit       (testCase)
import           Test.Framework.Providers.QuickCheck2 (testProperty)
import           Test.HUnit                           (Assertable (assert), assertBool, assertEqual, assertFailure)
import           Test.QuickCheck                      (Gen, arbitrary, elements, oneof, variant)
------------------------------------------------------------------------------


tests :: [Test]
tests = [ testFail
        , testAlternative
        , testEarlyTermination
        , testEscapeHttp
        , testCatchFinishWith
        , testRqBody
        , testRqBodyException
        , testRqBodyTermination
        , testRqBodyTooLong
        , testRqBodyTooSlow
        , testTrivials
        , testMethod
        , testMethods
        , testMethodEq
        , testMethodNotEq
        , testDir
        , testCatchIO
        , testWrites
        , testParam
        , testURLEncode1
        , testURLEncode2
        , testDir2
        , testIpHeaderFilter
        , testMZero404
        , testEvalSnap
        , testLocalRequest
        , testRedirect
        , testBracketSnap
        , testCoverInstances
        , testPathArgs
        , testStateTAndExceptions
        , test304Fixup
        , testChunkedFixup
        ]


------------------------------------------------------------------------------
expectSpecificException :: Exception e => e -> IO a -> IO ()
expectSpecificException e0 m = do
    r <- try m

    let b = either (\se -> isJust $
                           forceSameType (Just e0) (fromException se))
                   (const False)
                   r
    assertBool ("expected specific exception: " ++ show e0) b


------------------------------------------------------------------------------
expect404 :: IO (Request,Response) -> IO ()
expect404 m = do
    (_,r) <- m
    assertBool "expected 404" (rspStatus r == 404)


------------------------------------------------------------------------------
expectNo404 :: IO (Request,Response) -> IO ()
expectNo404 m = do
    (_,r) <- m
    assertBool ("expected 200, got " ++ show (rspStatus r))
               (rspStatus r /= 404)


------------------------------------------------------------------------------
mkRequest :: ByteString -> IO Request
mkRequest uri = Test.buildRequest $ Test.get uri Map.empty


------------------------------------------------------------------------------
mkRequestQuery :: ByteString -> ByteString -> [ByteString] -> IO Request
mkRequestQuery uri k v =
    Test.buildRequest $ Test.get uri $ Map.fromList [(k,v)]


------------------------------------------------------------------------------
mkZomgRq :: IO Request
mkZomgRq = Test.buildRequest $ Test.get "/" Map.empty


------------------------------------------------------------------------------
mkMethodRq :: Method -> IO Request
mkMethodRq m = Test.buildRequest $ do
                   Test.get "/" Map.empty
                   Test.setRequestType $ Test.RequestWithRawBody m ""


------------------------------------------------------------------------------
mkIpHeaderRq :: IO Request
mkIpHeaderRq = do
    rq <- mkZomgRq
    return $ setHeader "X-Forwarded-For" "1.2.3.4"
           $ deleteHeader "X-Forwarded-For"
           $ setHeader "X-Forwarded-For" "1.2.3.4" rq


------------------------------------------------------------------------------
mkRqWithBody :: IO Request
mkRqWithBody = Test.buildRequest $ Test.postRaw "/" "text/plain" "zazzle"


------------------------------------------------------------------------------
mkRqWithEnum :: (InputStream ByteString) -> IO Request
mkRqWithEnum str = do
    rq <- Test.buildRequest $ Test.postRaw "/" "text/plain" ""

    return $! rq { rqBody = str }


------------------------------------------------------------------------------
testCatchIO :: Test
testCatchIO = testCase "core/catchIO" $ do
    (_,rsp)  <- go f
    (_,rsp2) <- go g

    assertEqual "catchIO 1" (Just "bar") $ getHeader "foo" rsp
    assertEqual "catchIO 2" Nothing $ getHeader "foo" rsp2

  where
    f :: Snap ()
    f = (mask $ \restore -> restore $ throwIO $ NoHandlerException "")
            `catch` h

    g :: Snap ()
    g = return () `catch` h

    h :: SomeException -> Snap ()
    h e = e `seq` modifyResponse $ addHeader "foo" "bar"


------------------------------------------------------------------------------
go :: Snap a -> IO (Request,Response)
go m = do
    zomgRq <- mkZomgRq
    runSnap m dummy timeoutModifier zomgRq
  where
    dummy !x = return $! (show x `using` rdeepseq) `seq` ()
    timeoutModifier !f = return $! f 0 `seq` ()


------------------------------------------------------------------------------
goMeth :: Method -> Snap a -> IO (Request,Response)
goMeth m s = do
    methRq <- mkMethodRq m
    runSnap s dummy timeoutModifier methRq
  where
    dummy !x = return $! (show x `using` rdeepseq) `seq` ()
    timeoutModifier !f = return $! f 0 `seq` ()


------------------------------------------------------------------------------
goIP :: Snap a -> IO (Request,Response)
goIP m = do
    rq <- mkIpHeaderRq
    runSnap m dummy timeoutModifier rq
  where
    timeoutModifier !f = return $! f 0 `seq` ()
    dummy = const $ return ()


------------------------------------------------------------------------------
goPath :: ByteString -> Snap a -> IO (Request,Response)
goPath s m = do
    rq <- mkRequest s
    runSnap m dummy timeoutModifier rq
  where
    timeoutModifier !f = return $! f 0 `seq` ()
    dummy = const $ return ()


------------------------------------------------------------------------------
goPathQuery :: ByteString
            -> ByteString
            -> [ByteString]
            -> Snap a
            -> IO (Request,Response)
goPathQuery s k v m = do
    rq <- mkRequestQuery s k v
    runSnap m dummy (const (return ())) rq
  where
    dummy = const $ return ()


------------------------------------------------------------------------------
goBody :: Snap a -> IO (Request,Response)
goBody m = do
    rq <- mkRqWithBody
    runSnap m dummy (const (return ())) rq
  where
    dummy = const $ return ()


------------------------------------------------------------------------------
goEnum :: InputStream ByteString
       -> Snap b
       -> IO (Request,Response)
goEnum enum m = do
    rq <- mkRqWithEnum enum
    runSnap m logerr tout rq


------------------------------------------------------------------------------
testFail :: Test
testFail = testCase "failure" $ expect404 (go pass)


------------------------------------------------------------------------------
setFoo :: ByteString -> Snap ()
setFoo s = do
    modifyResponse (addHeader "Foo" s)
    fmap id $ pure ()
    pure id <*> (liftIO $ return ())
    !x <- liftBase $! return $! ()
    return $! x


------------------------------------------------------------------------------
testAlternative :: Test
testAlternative = testCase "core/alternative" $ do
    (_,resp) <- go (pass <|> setFoo "Bar")
    assertEqual "foo present" (Just "Bar") $ getHeader "Foo" resp

    (_,resp2) <- go (fail "fail should not error"
                       <|> fail2
                       <|> setFoo "Bar"
                       <|> setFoo "Baz")
    assertEqual "alternative chooses correct branch"
                (Just "Bar") $ getHeader "Foo" resp2

  where
    fail2 :: Snap ()
    fail2 = pass >>= \_ -> return ()


------------------------------------------------------------------------------
sampleResponse :: Response
sampleResponse = addHeader "Foo" "Quux" $ emptyResponse


------------------------------------------------------------------------------
testEarlyTermination :: Test
testEarlyTermination = testCase "core/earlyTermination" $ do
    (_,resp) <- go (finishWith sampleResponse >>= \_ -> setFoo "Bar")
    assertEqual "foo" (Just "Quux") $ getHeader "Foo" resp


------------------------------------------------------------------------------
testStateTAndExceptions :: Test
testStateTAndExceptions = testCase "core/stateT_exceptions" $ do
    Test.evalHandler (return ()) h1 >>= assertEqual "h1" True
    Test.evalHandler (return ()) h2 >>= assertEqual "h2" True
    Test.evalHandler (return ()) h3 >>= assertEqual "h3" True
    Test.evalHandler (return ()) h4 >>= assertEqual "h4" True
    Test.evalHandler (return ()) h5 >>= assertEqual "h5" True

  where
    useState = do rq <- getRequest
                  return (rqURI rq == "/")

    h1 = do let m = ((try mzero) :: Snap (Either SomeException Int))
            (m >> return False) <|> useState

    h2 = do catchFinishWith (getResponse >>= finishWith)
            useState

    h3 = do catchFinishWith (return ())
            useState

    h4 = do (void (catchFinishWith mzero)) <|> return ()
            useState

    h5 = do let m1 = (void (getResponse >>= finishWith)) `mplus` return ()
            void (catchFinishWith m1)
            useState


------------------------------------------------------------------------------
testEscapeHttp :: Test
testEscapeHttp = testCase "core/escapeHttp" $ flip catch catchEscape $ do
    (_, _) <- go (escapeHttp escaper)
    assertFailure "HTTP escape was ignored"
  where
    escaper _ _ _ = liftIO $ assert True
    tickle _      = return ()

    catchEscape (ex :: EscapeSnap) =
        case ex of
          EscapeHttp e -> do
              input  <- Streams.nullInput
              output <- Streams.nullOutput
              e tickle input output
          _ -> assertFailure "got TerminateConnection"


------------------------------------------------------------------------------
isLeft :: Either a b -> Bool
isLeft (Left _) = True
isLeft _        = False


------------------------------------------------------------------------------
isRight :: Either a b -> Bool
isRight (Right _) = True
isRight _         = False


------------------------------------------------------------------------------
logerr :: ByteString -> IO ()
logerr !_ = return $! ()


------------------------------------------------------------------------------
tout :: (Int -> Int) -> IO ()
tout !f = let !_ = f 2 in return $! ()


------------------------------------------------------------------------------
testBracketSnap :: Test
testBracketSnap = testCase "core/bracketSnap" $ do
    rq <- mkZomgRq

    ref <- newIORef 0

    expectSpecificException (NoHandlerException "") $
        evalSnap (act ref) logerr tout rq

    y <- readIORef ref
    assertEqual "bracketSnap/after1" (1::Int) y

    expectSpecificException (ErrorCall "no value") $
        evalSnap (act ref <|> finishWith emptyResponse)
                 logerr
                 tout
                 rq

    y' <- readIORef ref
    assertEqual "bracketSnap/after" 2 y'


    expectSpecificException (ErrorCall "foo") $
        evalSnap (act2 ref)
                 logerr
                 tout
                 rq

    y'' <- readIORef ref
    assertEqual "bracketSnap/after" 3 y''

  where
    act ref = bracketSnap (liftIO $ readIORef ref)
                          (\z -> liftIO $ writeIORef ref $! z+1)
                          (\z -> z `seq` mzero)

    act2 ref = bracketSnap (liftIO $ readIORef ref)
                           (\z -> liftIO $ writeIORef ref $! z+1)
                           (\z -> z `seq` liftIO $ throwIO $ ErrorCall "foo")


------------------------------------------------------------------------------
testCatchFinishWith :: Test
testCatchFinishWith = testCase "core/catchFinishWith" $ do
    rq <- mkZomgRq
    x <- evalSnap (catchFinishWith $ finishWith emptyResponse)
                  logerr tout rq
    assertBool "catchFinishWith" $ isLeft x
    let (Left resp) = x
    assertEqual "code" 200 (rspStatus resp)

    y <- evalSnap (catchFinishWith $ return $! ())
                  logerr tout rq
    assertBool "catchFinishWith" $ isRight y
    let (Right val) = y
    assertEqual "val" () val

    expectExceptionH $ evalSnap (catchFinishWith pass) logerr tout rq


------------------------------------------------------------------------------
testRqBody :: Test
testRqBody = testCase "core/requestBodies" $ do
    mvar1 <- newEmptyMVar
    mvar2 <- newEmptyMVar

    _ <- goBody $ f mvar1 mvar2

    v1 <- takeMVar mvar1
    v2 <- takeMVar mvar2

    assertEqual "rq body" "zazzle" v1
    assertEqual "rq body 2" "" v2

    (_,rsp) <- goBody (g >> putResponse emptyResponse)
    bd      <- getBody rsp

    assertEqual "detached rq body" "zazzle" bd
    assertBool "transforming" (rspTransformingRqBody rsp)

  where
    f mvar1 mvar2 = do
        readRequestBody 100000 >>= liftIO . putMVar mvar1
        readRequestBody 100000 >>= liftIO . putMVar mvar2

    g = transformRequestBody (return . id)


------------------------------------------------------------------------------
testRqBodyTooLong :: Test
testRqBodyTooLong = testCase "core/requestBodyTooLong" $ do
    expectExceptionH $ goBody $ f 2
    (_, rsp) <- goBody $ f 200000
    bd       <- getBody rsp
    assertEqual "detached rq body" "zazzle" bd
  where
    f sz = readRequestBody sz >>= writeLBS


------------------------------------------------------------------------------
testRqBodyException :: Test
testRqBodyException = testCase "core/requestBodyException" $ do
    str <- Streams.fromList listData
    (req,resp) <- goEnum str hndlr
    bd         <- getBody resp
    b'         <- Streams.toList $ rqBody req
    assertEqual "request body was consumed" [] b'
    assertEqual "response body was produced" "OK" bd
  where
    listData = ["the", "quick", "brown", "fox"]

    h0 = runRequestBody $ \str -> do
             !_ <- Streams.read str
             throwIO $ ErrorCall "foo"

    hndlr = h0 `catch` \(_::SomeException) -> writeBS "OK"


------------------------------------------------------------------------------
testRqBodyTooSlow :: Test
testRqBodyTooSlow = testCase "core/requestBodyTooSlow" $ do
    str <- Streams.makeInputStream strFunc >>=
           Streams.throwIfTooSlow (return ()) 100000.0 1
    expectExceptionH (goEnum str hndlr)

  where
    strFunc = waitabit >> return (Just "1")
    hndlr = runRequestBody $ \_ -> throwIO $ ErrorCall "foo"


------------------------------------------------------------------------------
testRqBodyTermination :: Test
testRqBodyTermination = testCase "core/requestBodyTermination" $ do
    str <- Streams.fromList ["the", "quick", "brown", "fox"]
    expectExceptionH $ goEnum str h0
  where
    h0 = (runRequestBody $ \str -> do
              !_ <- Streams.read str
              throwIO $ TerminateConnection
                      $ SomeException $ ErrorCall "foo")
           `catch` tc

    tc (ex :: EscapeSnap) = case ex of
                              TerminateConnection e -> terminateConnection e
                              _                     -> throwIO ex


------------------------------------------------------------------------------
testTrivials :: Test
testTrivials = testCase "core/trivials" $ do
    (rq,rsp) <- go $ do
        req <- getRequest
        putRequest $ req { rqIsSecure=True }
        putResponse $ setResponseStatus 333 "333" sampleResponse
        r <- getResponse
        liftIO $ assertEqual "rsp status" 333 $ rspStatus r
        code <- getsResponse rspStatus
        liftIO $ assertEqual "rsp status 2" 333 code
        !_ <- localRequest (\x -> x {rqIsSecure=False}) $ do
            q <- getRequest
            liftIO $ assertEqual "localrq" False $ rqIsSecure q
            return ()

        !_ <- logError "foo"
        writeText "zzz"
        writeLazyText "zzz"

        let req' = updateContextPath 0 req
        let cp1 = rqContextPath req
        let cp2 = rqContextPath req'

        setTimeout 30
        !_ <- getParams
        !_ <- getPostParams
        !_ <- getQueryParams

        liftIO $ assertEqual "updateContextPath 0" cp1 cp2

        withRequest $ return . (`seq` ())
        withResponse $ return . (`seq` ())

        return ()

    b <- getBody rsp
    coverShowInstance b
    coverShowInstance $ NoHandlerException ""
    coverShowInstance GET
    coverReadInstance GET
    coverEqInstance GET
    coverEqInstance $ NoHandlerException ""
    coverOrdInstance GET

    Prelude.map (\(x,y) -> (x,show y)) (IM.toList statusReasonMap)
            `deepseq` return ()

    let cookie = Cookie "" "" Nothing Nothing Nothing False False
    coverEqInstance cookie
    coverShowInstance cookie

    assertEqual "rq secure" True $ rqIsSecure rq
    assertEqual "rsp status" 333 $ rspStatus rsp
    coverTypeableInstance (undefined :: Snap ())
    coverShowInstance (EscapeHttp undefined)

    -- number serialization
    forM_ [ 0, 1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 10000000000
          , 100000000000
          ] $ \i -> do
              let s = show i
              rsp_cl <- Test.runHandler (return ()) (clHandler i)
              assertEqual ("number " ++ s)
                          (Just $ S.pack s)
                          (getHeader "content-length" rsp_cl)
  where
    clHandler i = do modifyResponse (setContentLength i)
                     writeBS (S.replicate (fromEnum i) ' ')

------------------------------------------------------------------------------
testMethod :: Test
testMethod = testCase "core/method" $ do
   expect404 $ go (method POST $ return ())
   expectNo404 $ go (method GET $ return ())


------------------------------------------------------------------------------
testMethods :: Test
testMethods = testCase "core/methods" $ do
   expect404 $ go (methods [POST,PUT,PATCH,Method "MOVE"] $ return ())
   expectNo404 $ go (methods [GET] $ return ())
   expectNo404 $ go (methods [POST,GET] $ return ())
   expectNo404 $ go (methods [PUT,GET] $ return ())
   expectNo404 $ go (methods [GET,PUT,DELETE] $ return ())
   expectNo404 $ go (methods [GET,PUT,DELETE,PATCH] $ return ())
   expectNo404 $ go (methods [GET,Method "COPY"] $ return ())
   expect404 $ goMeth PATCH (methods [POST,PUT,GET,Method "FOO"] $ return ())
   expect404 $ goMeth (Method "Baz")
     (methods [GET,POST,Method "Foo"] $ return ())
   expectNo404 $ goMeth (Method "Baz")
     (method (Method "Baz") $ return ())
   expectNo404 $ goMeth (Method "Foo")
     (methods [Method "Baz",PATCH,GET,Method "Foo"] $ return ())

   expectNo404 $ goMeth GET (method (Method "GET") $ return ())
   expectNo404 $ goMeth (Method "GET") (method GET $ return ())


------------------------------------------------------------------------------
methodGen :: Int -> Gen Method
methodGen n = variant n $ oneof
              [ elements [ GET, HEAD, POST, PUT, DELETE
                         , TRACE, OPTIONS, CONNECT, PATCH ]
              , Method <$> arbitrary
              ]


------------------------------------------------------------------------------
testMethodEq :: Test
testMethodEq = testProperty "core/Method/eq" $ prop
  where
    prop n = do
      m <- methodGen n
      return $ m == m && toMeth m == m
    toMeth GET     = Method "GET"
    toMeth HEAD    = Method "HEAD"
    toMeth POST    = Method "POST"
    toMeth PUT     = Method "PUT"
    toMeth DELETE  = Method "DELETE"
    toMeth TRACE   = Method "TRACE"
    toMeth OPTIONS = Method "OPTIONS"
    toMeth CONNECT = Method "CONNECT"
    toMeth PATCH   = Method "PATCH"
    toMeth (Method a) = Method a


------------------------------------------------------------------------------
testMethodNotEq :: Test
testMethodNotEq = testProperty "core/Method/noteq" $ prop
  where
    prop n = do
      m <- methodGen n
      m' <- methodGen (n + 1)
      return $ (m /= m') == not (m == m')


------------------------------------------------------------------------------
testDir :: Test
testDir = testCase "core/dir" $ do
   expect404 $ goPath "foo/bar" (dir "zzz" $ return ())
   expectNo404 $ goPath "foo/bar" (dir "foo" $ return ())
   expect404 $ goPath "fooz/bar" (dir "foo" $ return ())
   expectNo404 $ goPath "foo/bar" (path "foo/bar" $ return ())
   expect404 $ goPath "foo/bar/z" (path "foo/bar" $ return ())
   expectNo404 $ goPath "" (ifTop $ return ())
   expect404 $ goPath "a" (ifTop $ return ())


------------------------------------------------------------------------------
testParam :: Test
testParam = testCase "core/getParam" $ do
    expect404 $ goPath "/foo" f
    expectNo404 $ goPathQuery "/foo" "param" ["foo"] f
    expectNo404 $ goPathQuery "/foo" "param" ["foo"] fQ
    expect404 $ goPathQuery "/foo" "param" ["foo"] fP

  where
    p gp = do
        mp <- gp "param"
        maybe pass
              (\s -> if s == "foo" then return () else pass)
              mp

    f  = p getParam
    fQ = p getQueryParam
    fP = p getPostParam


------------------------------------------------------------------------------
getBody :: Response -> IO L.ByteString
getBody r = liftM (L.fromChunks . (:[])) $ Test.getResponseBody r


------------------------------------------------------------------------------
testWrites :: Test
testWrites = testCase "core/writes" $ do
    (_,r) <- go h
    b <- getBody r
    assertEqual "output functions" "Foo1Foo2Foo3" b
  where
    h :: Snap ()
    h = do
        addToOutput f
        writeBS "Foo2"
        writeLBS "Foo3"

    f str = do
        Streams.write (Just $ byteString "Foo1") str
        return str


------------------------------------------------------------------------------
testURLEncode1 :: Test
testURLEncode1 = testCase "core/urlEncoding1" $ do
    let b = urlEncode "the quick brown fox~#"
    assertEqual "url encoding 1" "the+quick+brown+fox%7e%23" b
    assertEqual "fail" Nothing $ urlDecode "%"


------------------------------------------------------------------------------
testURLEncode2 :: Test
testURLEncode2 = testProperty "core/urlEncoding2" prop
  where
    prop s = (urlDecode $ urlEncode s) == Just s


------------------------------------------------------------------------------
testDir2 :: Test
testDir2 = testCase "core/dir2" $ do
    (_,resp) <- goPath "foo/bar" f
    b <- getBody resp
    assertEqual "context path" "/foo/bar/" b

  where
    f = dir "foo" $ dir "bar" $ do
            p <- liftM rqContextPath getRequest
            addToOutput $ \s -> do
                Streams.write (Just $ byteString p) s
                return s


------------------------------------------------------------------------------
testIpHeaderFilter :: Test
testIpHeaderFilter = testCase "core/ipHeaderFilter" $ do
    (_,r) <- goIP f
    b <- getBody r
    assertEqual "ipHeaderFilter" "1.2.3.4" b


    (_,r2) <- go f'
    b2 <- getBody r2
    assertEqual "ipHeaderFilter" "127.0.0.1" b2

  where
    f = do
        ipHeaderFilter
        ip <- liftM rqClientAddr getRequest
        writeBS ip

    f' = do
        ipHeaderFilter
        ip <- liftM rqRemoteAddr getRequest
        writeBS ip


------------------------------------------------------------------------------
testMZero404 :: Test
testMZero404 = testCase "core/mzero404" $ do
    (_,r) <- go mzero
    b <- getBody r
    assertBool "mzero 404" ("<!DOCTYPE html" `L.isPrefixOf` b)


testEvalSnap :: Test
testEvalSnap = testCase "core/evalSnap-exception" $ do
    rq <- mkZomgRq
    expectExceptionH (evalSnap f logerr tout rq >> return ())
  where
    f = do
        logError "zzz"
        v <- withResponse (return . rspStatus)
        liftIO $ assertEqual "evalSnap rsp status" 200 v
        finishWith emptyResponse


------------------------------------------------------------------------------
testLocalRequest :: Test
testLocalRequest = testCase "core/localRequest" $ do
    rq1 <- mkZomgRq
    rq2 <- mkRequest "zzz/zz/z"

    let h = localRequest (const rq2) mzero

    (rq',_) <- go (h <|> return ())

    let u1 = rqURI rq1
    let u2 = rqURI rq'

    assertEqual "localRequest backtrack" u1 u2


------------------------------------------------------------------------------
testRedirect :: Test
testRedirect = testCase "core/redirect" $ do
    (_,rsp)  <- go (redirect "/foo/bar")

    b <- getBody rsp
    assertEqual "no response body" "" b
    assertEqual "response content length" (Just 0) $ rspContentLength rsp
    assertEqual "redirect path" (Just "/foo/bar") $ getHeader "Location" rsp
    assertEqual "redirect status" 302 $ rspStatus rsp
    assertEqual "status description" "Found" $ rspStatusReason rsp


    (_,rsp2)  <- go (redirect' "/bar/foo" 307)

    assertEqual "redirect path" (Just "/bar/foo") $ getHeader "Location" rsp2
    assertEqual "redirect status" 307 $ rspStatus rsp2
    assertEqual "status description" "Temporary Redirect" $
                rspStatusReason rsp2


------------------------------------------------------------------------------
testCoverInstances :: Test
testCoverInstances = testCase "core/instances" $ do
#if !MIN_VERSION_transformers(0,6,0)
    coverErrorT
    coverListT
#endif
#if MIN_VERSION_transformers(0,4,0)
    coverExceptT
#endif
    coverRWST
    coverLRWS
    coverReaderT
    coverStateT
    coverLStateT
    coverWriterT
    coverLWriterT

  where
    snap :: MonadSnap m => m ()
    snap = liftSnap $ writeBS "OK"

    cover :: MonadSnap m => (m () -> Snap ()) -> IO ()
    cover runFunc = do
        !_ <- Test.runHandler (return ()) (runFunc snap)
        return ()

    rwst :: RWST () () () Snap () -> Snap ()
    rwst m = void $ runRWST m () ()

    lrwst :: LRWS.RWST () () () Snap () -> Snap ()
    lrwst m = void $ LRWS.runRWST m () ()

    wt :: WriterT () Snap () -> Snap ()
    wt m = void $ runWriterT m

    lwt :: LWriter.WriterT () Snap () -> Snap ()
    lwt m = void $ LWriter.runWriterT m

#if !MIN_VERSION_transformers(0,6,0)
    coverErrorT   = cover (\m -> do
                               (_ :: Either String ()) <- runErrorT m
                               return ())
    coverListT    = cover (void . runListT)
#endif
#if MIN_VERSION_transformers(0,4,0)
    coverExceptT  = cover (\m -> do
                               (_ :: Either String ()) <- runExceptT m
                               return ())
#endif
    coverRWST     = cover rwst
    coverLRWS     = cover lrwst
    coverReaderT  = cover (flip runReaderT ())
    coverStateT   = cover (flip evalStateT ())
    coverLStateT  = cover (flip LState.evalStateT ())
    coverWriterT  = cover wt
    coverLWriterT = cover lwt


------------------------------------------------------------------------------
testPathArgs :: Test
testPathArgs = testCase "core/pathArgs" $ do
    (_, rsp) <- goPath "%e4%b8%ad" m
    b <- getBody rsp
    assertEqual "pathargs url- and utf8-decodes" "ok" b

    Test.evalHandler (Test.get "/%zzzz" Map.empty) m2 >>= assertEqual "m2" True
    Test.evalHandler (Test.get "/z/foo" Map.empty) m3 >>= assertEqual "m3" "/z/"

  where
    m = pathArg f

    m2 = pathArg (\(_ :: Text) -> return False) <|> return True

    m3 = pathArg (\(_ :: Text) -> rqContextPath <$> getRequest)


    f x = if x == ("\x4e2d" :: Text)
            then writeBS "ok"
            else writeBS $ "not ok: " `mappend` T.encodeUtf8 x

------------------------------------------------------------------------------
test304Fixup :: Test
test304Fixup = testCase "core/304fixup" $ do
    rsp1 <- Test.runHandler (return ()) h1
    assertEqual "code1" (rspStatus rsp1) 304
    assertEqual "cl1" Nothing (rspContentLength rsp1)
    Test.getResponseBody rsp1 >>= assertEqual "body1" ""
    assertBool "date" $ getHeader "date" rsp1 /= (Just "zzz")
    assertEqual "cl-header" Nothing $ getHeader "content-length" rsp1
    assertEqual "transfer-encoding" Nothing $ getHeader "transfer-encoding" rsp1

  where
    h1 = do let s = "this should get eaten"
            modifyResponse (setResponseCode 304 .
                            setContentLength (toEnum $ S.length s) .
                            setHeader "content-length" "zzz" .
                            setHeader "transfer-encoding" "chunked" .
                            setHeader "date" "zzz")
            writeBS s


------------------------------------------------------------------------------
testChunkedFixup :: Test
testChunkedFixup = testCase "core/chunked-fixup" $ do
    rsp1 <- Test.runHandler (return ()) h1
    Test.getResponseBody rsp1 >>= assertEqual "body1" "OK"
    assertEqual "transfer-encoding" (Just "chunked")
        $ getHeader "transfer-encoding" rsp1
    assertEqual "baz" (Just "baz") $ getHeader "baz" rsp1
    assertEqual "foo" (Just "foo") $ getHeader "foo" rsp1

  where
    h1 = do modifyResponse $ setHeader "baz" "baz" .
                             setHeader "transfer-encoding" "chunked" .
                             setHeader "foo" "foo" .
                             setHeader "bar" "bar"
            writeBS "OK"