Tests.hs

{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Snap.Internal.Http.Server.Session.Tests (tests) where

------------------------------------------------------------------------------
#if !MIN_VERSION_base(4,6,0)
import           Prelude                           hiding (catch)
#endif
import           Control.Concurrent                (MVar, forkIO, killThread, modifyMVar_, myThreadId, newChan, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar, threadDelay, throwTo, withMVar)
import           Control.Exception.Lifted          (AsyncException (ThreadKilled), Exception, SomeException (..), bracket, catch, evaluate, mask, throwIO, try)
import           Control.Monad                     (forM_, liftM, replicateM_, void, when, (>=>))
import           Control.Monad.State.Class         (modify)
import           Data.ByteString.Builder           (Builder, byteString, char8, toLazyByteString)
import           Data.ByteString.Builder.Extra     (flush)
import           Data.ByteString.Builder.Internal  (newBuffer)
import           Data.ByteString.Char8             (ByteString)
import qualified Data.ByteString.Char8             as S
import qualified Data.ByteString.Lazy.Char8        as L
import qualified Data.CaseInsensitive              as CI
import           Data.IORef                        (IORef, newIORef, readIORef, writeIORef)
import qualified Data.Map                          as Map
import           Data.Maybe                        (isNothing)
import           Data.Monoid                       (mappend)
import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime)
import           Data.Typeable                     (Typeable)
import           Data.Word                         (Word64)
import qualified Network.Http.Client               as Http
import           System.IO.Streams                 (InputStream, OutputStream)
import qualified System.IO.Streams                 as Streams
import qualified System.IO.Streams.Concurrent      as Streams
import qualified System.IO.Streams.Debug           as Streams
import           System.Timeout                    (timeout)
import           Test.Framework                    (Test, testGroup)
import           Test.Framework.Providers.HUnit    (testCase)
import qualified Test.Framework.Runners.Console    as Console
import           Test.HUnit                        (assertBool, assertEqual)
------------------------------------------------------------------------------
import           Snap.Core                         (Cookie (Cookie, cookieName, cookieValue), Request (rqContentLength, rqCookies, rqHostName, rqLocalHostname, rqPathInfo, rqQueryString, rqURI), Snap, addResponseCookie, escapeHttp, getHeader, getRequest, getsRequest, modifyResponse, readRequestBody, rqParam, rqPostParam, rqQueryParam, sendFile, sendFilePartial, setContentLength, setHeader, setResponseBody, setResponseStatus, terminateConnection, writeBS, writeBuilder, writeLBS)
import           Snap.Http.Server.Types            (emptyServerConfig, getDefaultTimeout, getIsSecure, getLocalAddress, getLocalHostname, getLocalPort, getLogAccess, getLogError, getNumAcceptLoops, getOnDataFinished, getOnEscape, getOnException, getOnNewRequest, getOnParse, getOnUserHandlerFinished, getRemoteAddress, getRemotePort, getTwiddleTimeout, isNewConnection, setDefaultTimeout, setIsSecure, setLocalHostname, setLogAccess, setLogError, setNumAcceptLoops, setOnDataFinished, setOnEscape, setOnException, setOnNewRequest, setOnParse, setOnUserHandlerFinished)
import           Snap.Internal.Http.Server.Date    (getLogDateString)
import           Snap.Internal.Http.Server.Session (BadRequestException (..), LengthRequiredException (..), TerminateSessionException (..), httpAcceptLoop, httpSession, snapToServerHandler)
import qualified Snap.Internal.Http.Server.TLS     as TLS
import           Snap.Internal.Http.Server.Types   (AcceptFunc (AcceptFunc), PerSessionData (PerSessionData, _isNewConnection), SendFileHandler, ServerConfig (_logError))
import           Snap.Test                         (RequestBuilder)
import qualified Snap.Test                         as T
import           Snap.Test.Common                  (coverShowInstance, coverTypeableInstance, expectException)
#ifdef OPENSSL
import qualified Network.Socket                    as N
#endif


------------------------------------------------------------------------------
tests :: [Test]
tests = [ testPong
        , testPong1_0
        , testDateHeaderDeleted
        , testServerHeader
        , testBadParses
        , testEof
        , testHttp100
        , testNoHost
        , testNoHost1_0
        , testChunkedRequest
        , testQueryParams
        , testPostParams
        , testPostParamsReplacementBody
        , testCookie
        , testSetCookie
        , testUserException
        , testUserBodyException
        , testEscape
        , testPostWithoutLength
        , testWeirdMissingSlash
        , testOnlyQueryString
        , testConnectionClose
        , testUserTerminate
        , testSendFile
        , testBasicAcceptLoop
        , testTrivials
#ifdef OPENSSL
        , testTLSKeyMismatch
#else
        , testCoverTLSStubs
#endif
        ]


------------------------------------------------------------------------------
#ifdef OPENSSL
testTLSKeyMismatch :: Test
testTLSKeyMismatch = testCase "session/tls-key-mismatch" $ do
    expectException $ bracket (TLS.bindHttps "127.0.0.1"
                                    (fromIntegral N.aNY_PORT)
                                    "test/cert.pem"
                                    False
                                    "test/bad_key.pem")
                              (N.close . fst)
                              (const $ return ())
    expectException $ bracket (TLS.bindHttps "127.0.0.1"
                                    (fromIntegral N.aNY_PORT)
                                    "test/cert.pem"
                                    True
                                    "test/bad_key.pem")
                              (N.close . fst)
                              (const $ return ())
#else
testCoverTLSStubs :: Test
testCoverTLSStubs = testCase "session/tls-stubs" $ do
    expectException $ TLS.bindHttps "127.0.0.1" 9999
                        "test/cert.pem" False "test/key.pem" Nothing
    expectException $ TLS.bindHttps "127.0.0.1" 9999
                        "test/cert.pem" True "test/key.pem" Nothing
    let (AcceptFunc afunc) = TLS.httpsAcceptFunc undefined undefined
    expectException $ mask $ \restore -> afunc restore
    let u = undefined
    expectException $ TLS.sendFileFunc u u u u u u u
#endif


------------------------------------------------------------------------------
testPong :: Test
testPong = testCase "session/pong" $ do
    do
      [(resp, body)] <- runRequestPipeline [return ()] snap1
      assertEqual "code1" 200 $ Http.getStatusCode resp
      assertEqual "body1" pong body
      assertEqual "chunked1" Nothing $
                            Http.getHeader resp "Transfer-Encoding"
    do
      [(resp, body)] <- runRequestPipeline [return ()] snap2
      assertEqual "code2" 200 $ Http.getStatusCode resp
      assertEqual "body2" pong body
      assertEqual "chunked2" (Just $ CI.mk "chunked") $
                             fmap CI.mk $
                             Http.getHeader resp "Transfer-Encoding"
    -- test pipelining
    do
      [_, (resp, body)] <- runRequestPipeline [return (), return ()] snap3
      assertEqual "code3" 233 $ Http.getStatusCode resp
      assertEqual "reason3" "ZOMG" $ Http.getStatusMessage resp
      assertEqual "body3" pong body
      assertEqual "chunked3" Nothing $ Http.getHeader resp "Transfer-Encoding"

    do
      [_, (resp, body)] <- runRequestPipeline [http_1_0, http_1_0] snap3
      assertEqual "code4" 233 $ Http.getStatusCode resp
      assertEqual "reason4" "ZOMG" $ Http.getStatusMessage resp
      assertEqual "body4" pong body
      assertEqual "chunked4" Nothing $ Http.getHeader resp "Transfer-Encoding"

  where
    http_1_0 = do
        T.setHttpVersion (1, 0)
        T.setHeader "Connection" "keep-alive"
    pong = "PONG"

    snap1 = writeBS pong >> modifyResponse (setContentLength 4)
    snap2 = do
        cookies <- getsRequest rqCookies
        if null cookies
          then writeBS pong
          else writeBS "wat"

    snap3 = do
        modifyResponse (setResponseStatus 233 "ZOMG" . setContentLength 4)
        writeBS pong

------------------------------------------------------------------------------
testPong1_0 :: Test
testPong1_0 = testCase "session/pong1_0" $ do
    req <- makeRequest (T.setHttpVersion (1, 0) >>
                        T.setHeader "Connection" "zzz")
    out <- getSessionOutput [req] $ writeBS "PONG"
    assertBool "200 ok" $ S.isPrefixOf "HTTP/1.0 200 OK\r\n" out
    assertBool "PONG" $ S.isSuffixOf "\r\n\r\nPONG" out


------------------------------------------------------------------------------
testDateHeaderDeleted :: Test
testDateHeaderDeleted = testCase "session/dateHeaderDeleted" $ do
    [(resp, _)] <- runRequestPipeline [mkRq] snap
    assertBool "date header" $ Just "plop" /= Http.getHeader resp "Date"

    [_, (resp2, _)] <- runRequestPipeline [mkRq2, mkRq2] snap
    assertBool "date header 2" $ Just "plop" /= Http.getHeader resp2 "Date"

  where
    snap = do
        modifyResponse (setHeader "Date" "plop" .
                        setHeader "Connection" "ok" .
                        setContentLength 4)
        writeBS "PONG"

    mkRq = do
        T.setHttpVersion (1,0)
        T.setHeader "fnargle" "plop"
        T.setHeader "Content-Length" "0"
        T.setHeader "Connection" "keep-alive"

    mkRq2 = do
        T.setHeader "fnargle" "plop"
        T.setHeader "Content-Length" "0"
        T.setHeader "Connection" "keep-alive"


------------------------------------------------------------------------------
testServerHeader :: Test
testServerHeader = testCase "session/serverHeader" $ do
    [(resp, _)] <- runRequestPipeline [return ()] snap
    assertEqual "server" (Just "blah") $ Http.getHeader resp "Server"
  where
    snap = modifyResponse $ setHeader "Server" "blah"


------------------------------------------------------------------------------
testBadParses :: Test
testBadParses = testGroup "session/badParses" [
                  check 1 "Not an HTTP Request"
                , check 2 $ S.concat [ "GET / HTTP/1.1\r\n"
                                     , "&*%^(*&*@YS\r\n\r324932\n)"
                                     ]
                , check 3 "\n"
                ]

  where
    check :: Int -> ByteString -> Test
    check n txt = testCase ("session/badParses/" ++ show n) $
                  expectException $ getSessionOutput [txt] (return ())


------------------------------------------------------------------------------
testEof :: Test
testEof = testCase "session/eof" $ do
    l <- runRequestPipeline [] snap
    assertBool "eof1" $ null l

    out <- getSessionOutput [""] snap
    assertEqual "eof2" "" out
  where
    snap = writeBS "OK"


------------------------------------------------------------------------------
testHttp100 :: Test
testHttp100 = testCase "session/expect100" $ do
    req <- makeRequest expect100
    out <- getSessionOutput [req] (writeBS "OK")

    assertBool "100-continue" $
               S.isPrefixOf "HTTP/1.1 100 Continue\r\n\r\nHTTP/1.1 200 OK" out

    req2 <- makeRequest expect100_2
    out2 <- getSessionOutput [req2] (writeBS "OK")

    assertBool "100-continue-2" $
               S.isPrefixOf "HTTP/1.0 100 Continue\r\n\r\nHTTP/1.0 200 OK" out2

  where
    expect100 = do
        queryGetParams
        T.setHeader "Expect" "100-continue"

    expect100_2 = do
        T.setHttpVersion (1, 0)
        queryGetParams
        T.setHeader "Expect" "100-continue"


------------------------------------------------------------------------------
testNoHost :: Test
testNoHost = testCase "session/noHost" $
             expectException $
             getSessionOutput ["GET / HTTP/1.1\r\n\r\n"] (writeBS "OK")


------------------------------------------------------------------------------
testNoHost1_0 :: Test
testNoHost1_0 = testCase "session/noHost1_0" $ do
    out <- getSessionOutput ["GET / HTTP/1.0\r\n\r\n"] snap1
    assertBool "no host 1.0" $ S.isSuffixOf "\r\nbackup-localhost" out
    out2 <- getSessionOutput ["GET / HTTP/1.0\r\n\r\n"] snap2
    assertBool "no host 1.0-2" $ S.isSuffixOf "\r\nbackup-localhost" out2
  where
    snap1 = getRequest >>= writeBS . rqHostName
    snap2 = getRequest >>= writeBS . rqLocalHostname


------------------------------------------------------------------------------
testChunkedRequest :: Test
testChunkedRequest = testCase "session/chunkedRequest" $ do
    [(_, body)] <- runRequestPipeline [chunked] snap
    assertEqual "chunked" "ok" body
  where
    snap = do
        m <- liftM (getHeader "Transfer-Encoding") getRequest
        if m == Just "chunked"
          then readRequestBody 2048 >>= writeLBS
          else writeBS "not ok"

    chunked = do
        T.put "/" "text/plain" "ok"
        T.setHeader "Transfer-Encoding" "chunked"


------------------------------------------------------------------------------
testQueryParams :: Test
testQueryParams = testCase "session/queryParams" $ do
    [(_, body)] <- runRequestPipeline [queryGetParams] snap
    assertEqual "queryParams" expected body

  where
    expected = S.unlines [
                 "param1=abc,def"
               , "param2=def"
               , "param1=abc,def"
               , "ok"
               ]
    snap = do
        rq <- getRequest
        let (Just l) = rqParam "param1" rq
        writeBS $ S.concat [ "param1="
                           , S.intercalate "," l
                           , "\n" ]
        let (Just m) = rqParam "param2" rq
        writeBS $ S.concat [ "param2="
                           , S.intercalate "," m
                           , "\n"]
        let (Just l') = rqQueryParam "param1" rq
        writeBS $ S.concat [ "param1="
                           , S.intercalate "," l'
                           , "\n" ]
        let z = if isNothing $ rqPostParam "param1" rq
                  then "ok\n" else "bad\n"
        writeBS z

        return ()


------------------------------------------------------------------------------
testPostParams :: Test
testPostParams = testCase "session/postParams" $ do
    [(_, body)] <- runRequestPipeline [queryPostParams] snap
    assertEqual "postParams" expected body

  where
    expected = S.unlines [
                 "param1=abc,abc"
               , "param2=def  ,zzz"
               , "param1=abc,abc"
               , "ok"
               , "param2=zzz"
               ]
    snap = do
        rq <- getRequest
        let (Just l) = rqParam "param1" rq
        writeBS $ S.concat [ "param1="
                           , S.intercalate "," l
                           , "\n" ]
        let (Just m) = rqParam "param2" rq
        writeBS $ S.concat [ "param2="
                           , S.intercalate "," m
                           , "\n"]
        let (Just l') = rqQueryParam "param1" rq
        writeBS $ S.concat [ "param1="
                           , S.intercalate "," l'
                           , "\n" ]
        let z = if isNothing $ rqPostParam "param1" rq
                  then "ok\n" else "bad\n"
        writeBS z

        let (Just p) = rqPostParam "param2" rq
        writeBS $ S.concat [ "param2="
                           , S.intercalate "," p
                           , "\n" ]

        return ()


------------------------------------------------------------------------------
testPostParamsReplacementBody :: Test
testPostParamsReplacementBody =
  testCase "session/postParamsReplacementBody" $ do
    [(_, body)] <- runRequestPipeline [queryPostParams] snap
    assertEqual "postParams" expected body

  where
    expected = "param2=zzz"
    snap = readRequestBody 2048 >>= writeLBS


------------------------------------------------------------------------------
testCookie :: Test
testCookie = testCase "session/cookie" $ do
    [(_, body)] <- runRequestPipeline [queryGetParams] snap
    assertEqual "cookie" expected body
  where
    expected = S.unlines [ "foo"
                         , "bar"
                         ]
    snap = do
        cookies <- liftM rqCookies getRequest
        forM_ cookies $ \cookie -> do
            writeBS $ S.unlines [ cookieName cookie
                                , cookieValue cookie
                                ]


------------------------------------------------------------------------------
testSetCookie :: Test
testSetCookie = testCase "session/setCookie" $ do
    mapM_ runTest $ zip3 [1..] expecteds cookies
  where
    runTest (n, expected, cookie) = do
        [(resp, _)] <- runRequestPipeline [queryGetParams] $ snap cookie
        assertEqual ("cookie" ++ show (n :: Int))
                    (Just expected)
                    (Http.getHeader resp "Set-Cookie")

    expecteds = [ S.intercalate "; "
                    [ "foo=bar"
                    , "path=/"
                    , "expires=Thu, 01-Jan-1970 00:16:40 GMT"
                    , "domain=localhost"
                    ]
                , "foo=bar"
                , "foo=bar; Secure; HttpOnly"
                ]

    cookies = [ Cookie "foo" "bar" (Just $ posixSecondsToUTCTime 1000)
                       (Just "localhost") (Just "/") False False
              , Cookie "foo" "bar" Nothing Nothing Nothing False False
              , Cookie "foo" "bar" Nothing Nothing Nothing True True
              ]

    snap cookie = do
        modifyResponse $ addResponseCookie cookie


------------------------------------------------------------------------------
testUserException :: Test
testUserException = testCase "session/userException" $ do
    expectException $ runRequestPipeline [queryGetParams] snap
  where
    snap = throwIO TestException


------------------------------------------------------------------------------
testUserBodyException :: Test
testUserBodyException = testCase "session/userBodyException" $ do
    expectException $ runRequestPipeline [queryGetParams] snap
  where
    snap = modifyResponse $ setResponseBody $ \os -> do
        Streams.write (Just (byteString "hi" `mappend` flush)) os
        throwIO TestException


------------------------------------------------------------------------------
testEscape :: Test
testEscape = testCase "session/testEscape" $ do
    req <- makeRequest (return ())
    out <- getSessionOutput [req, "OK?"] snap
    assertEqual "escape" "OK" out
  where
    snap = escapeHttp $ \tickle readEnd writeEnd -> do
         l <- Streams.toList readEnd
         tickle (max 20)
         let s = if l == ["OK?"]
                   then "OK"
                   else S.append "BAD: " $ S.pack $ show l
         Streams.write (Just $ byteString s) writeEnd
         Streams.write Nothing writeEnd


------------------------------------------------------------------------------
testPostWithoutLength :: Test
testPostWithoutLength = testCase "session/postWithoutLength" $ do
    let req = S.concat [ "POST / HTTP/1.1\r\nHost: localhost\r\n\r\n"
                       , "Blah blah blah blah blah"
                       ]

    is <- Streams.fromList [req]
    (os, getInput) <- listOutputStream
    expectException $ runSession is os (return ())
    out <- liftM S.concat getInput
    assertBool "post without length" $
        S.isPrefixOf "HTTP/1.1 411 Length Required" out


------------------------------------------------------------------------------
testWeirdMissingSlash :: Test
testWeirdMissingSlash = testCase "session/weirdMissingSlash" $ do
  do
    let req = "GET foo/bar?z HTTP/1.0\r\n\r\n"
    out <- getSessionOutput [req] snap
    assertBool "missing slash" $ expected1 `S.isSuffixOf` out
  do
    let req = "GET /foo/bar?z HTTP/1.0\r\n\r\n"
    out <- getSessionOutput [req] snap
    assertBool "with slash" $ expected2 `S.isSuffixOf` out

  where
    expected1 = S.concat [ "\r\n\r\n"
                         , "foo/bar?z\n"
                         , "foo/bar\n"
                         , "z\n"
                         ]
    expected2 = S.concat [ "\r\n\r\n"
                         , "/foo/bar?z\n"
                         , "foo/bar\n"
                         , "z\n"
                         ]
    p s = writeBuilder $ byteString s `mappend` char8 '\n'
    snap = do
        rq <- getRequest
        p $ rqURI rq
        p $ rqPathInfo rq
        p $ rqQueryString rq


------------------------------------------------------------------------------
testOnlyQueryString :: Test
testOnlyQueryString = testCase "session/onlyQueryString" $ do
  do
    let req = "GET ?z HTTP/1.0\r\n\r\n"
    out <- getSessionOutput [req] snap
    assertBool "missing slash" $ expected `S.isSuffixOf` out
  where
    expected = S.concat [ "\r\n\r\n"
                         , "?z\n"
                         , "\n"
                         , "z\n"
                         ]
    p s = writeBuilder $ byteString s `mappend` char8 '\n'
    snap = do
        rq <- getRequest
        p $ rqURI rq
        p $ rqPathInfo rq
        p $ rqQueryString rq


------------------------------------------------------------------------------
testConnectionClose :: Test
testConnectionClose = testCase "session/connectionClose" $ do
    do
      [(resp, _)] <- runRequestPipeline [return (), return ()] snap
      assertEqual "close1" (Just $ CI.mk "close") $
                           fmap CI.mk $
                           Http.getHeader resp "Connection"
    do
      [(resp, _)] <- runRequestPipeline [http1_0, http1_0] snap
      assertEqual "close2" (Just $ CI.mk "close") $
                           fmap CI.mk $
                           Http.getHeader resp "Connection"

    do
      [(resp, _)] <- runRequestPipeline [http1_0_2, http1_0] (return ())
      assertEqual "close3" (Just $ CI.mk "close") $
                           fmap CI.mk $
                           Http.getHeader resp "Connection"

  where
    http1_0 = T.setHttpVersion (1, 0)
    http1_0_2 = T.setHttpVersion (1, 0) >> T.setHeader "Connection" "fnargle"
    snap  = modifyResponse $ setHeader "Connection" "close"


------------------------------------------------------------------------------
testUserTerminate :: Test
testUserTerminate = testCase "session/userTerminate" $ do
    expectException $ runRequestPipeline [return ()] snap
  where
    snap = terminateConnection TestException


------------------------------------------------------------------------------
testSendFile :: Test
testSendFile = testCase "session/sendFile" $ do
    [(_, out1)] <- runRequestPipeline [return ()] snap1
    [(_, out2)] <- runRequestPipeline [return ()] snap2
    assertEqual "sendfile1" "TESTING 1-2-3\n" out1
    assertEqual "sendfile2" "EST" out2
  where
    snap1 = sendFile "test/dummy.txt"
    snap2 = sendFilePartial "test/dummy.txt" (1,4)


------------------------------------------------------------------------------
testBasicAcceptLoop :: Test
testBasicAcceptLoop = testCase "session/basicAcceptLoop" $
                      replicateM_ 1000 $ do
    outputs <- runAcceptLoop [return ()] (return ())
    let [Output out] = outputs
    void (evaluate out) `catch` \(e::SomeException) -> do
        throwIO e
    assertBool "basic accept" $ S.isPrefixOf "HTTP/1.1 200 OK\r\n" out


------------------------------------------------------------------------------
testTrivials :: Test
testTrivials = testCase "session/trivials" $ do
    coverShowInstance $ TerminateSessionException
                      $ SomeException BadRequestException
    coverShowInstance LengthRequiredException
    coverShowInstance BadRequestException
    coverShowInstance $ TLS.TLSException "ok"
    coverTypeableInstance (undefined :: TerminateSessionException)
    coverTypeableInstance (undefined :: BadRequestException)
    coverTypeableInstance (undefined :: LengthRequiredException)
    coverTypeableInstance (undefined :: TLS.TLSException)

    expectException (getOnNewRequest emptyServerConfig undefined >>= evaluate)
    is <- Streams.fromList []
    (os, _) <- Streams.listOutputStream
    psd <- makePerSessionData is os
    isNewConnection psd >>= assertEqual "new connection" False

    -- cover getters
    let !_ = getTwiddleTimeout psd
    let !_ = getRemotePort psd
    let !_ = getRemoteAddress psd
    let !_ = getLocalPort psd
    let !_ = getLocalAddress psd
    getOnParse emptyServerConfig undefined undefined
    getOnEscape emptyServerConfig undefined
    getOnException emptyServerConfig undefined undefined
    getOnDataFinished emptyServerConfig undefined undefined undefined
    getOnUserHandlerFinished emptyServerConfig undefined undefined undefined
    getLogError emptyServerConfig undefined
    getLogAccess emptyServerConfig undefined undefined undefined
    let !_ = getLogError emptyServerConfig
    let !_ = getLocalHostname emptyServerConfig
    let !_ = getDefaultTimeout emptyServerConfig
    let !_ = getNumAcceptLoops emptyServerConfig
    let !_ = getIsSecure emptyServerConfig

    !x <- getLogDateString
    threadDelay $ 2 * seconds
    !y <- getLogDateString
    assertBool (concat ["log dates: ", show x, ", ", show y]) $ x /= y


                             ---------------------
                             -- query fragments --
                             ---------------------

------------------------------------------------------------------------------
queryGetParams :: RequestBuilder IO ()
queryGetParams = do
    T.get "/foo/bar.html" $ Map.fromList [ ("param1", ["abc", "def"])
                                         , ("param2", ["def"])
                                         ]
    T.addCookies [ Cookie "foo" "bar" Nothing (Just "localhost") (Just "/")
                          False False ]
    modify $ \rq -> rq { rqContentLength = Just 0 }


------------------------------------------------------------------------------
queryPostParams :: RequestBuilder IO ()
queryPostParams = do
    T.postUrlEncoded "/" $ Map.fromList [ ("param2", ["zzz"]) ]
    T.setQueryStringRaw "param1=abc&param2=def%20+&param1=abc"


                            -----------------------
                            -- utility functions --
                            -----------------------

------------------------------------------------------------------------------
_run :: [Test] -> IO ()
_run l = Console.defaultMainWithArgs l ["--plain"]


------------------------------------------------------------------------------
-- | Given a request builder, produce the HTTP request as a ByteString.
makeRequest :: RequestBuilder IO a -> IO ByteString
makeRequest = (T.buildRequest . void) >=> T.requestToString


------------------------------------------------------------------------------
mockSendFileHandler :: OutputStream ByteString -> SendFileHandler
mockSendFileHandler os !_ hdrs fp start nbytes = do
    let hstr = toByteString hdrs
    Streams.write (Just hstr) os

    Streams.withFileAsInputStartingAt (fromIntegral start) fp $
        Streams.takeBytes (fromIntegral nbytes) >=> Streams.supplyTo os

    Streams.write Nothing os


------------------------------------------------------------------------------
-- | Fill in a 'PerSessionData' with some dummy values.
makePerSessionData :: InputStream ByteString
                   -> OutputStream ByteString
                   -> IO PerSessionData
makePerSessionData readEnd writeEnd = do
    forceConnectionClose <- newIORef False
    let twiddleTimeout f = let z = f 0 in z `seq` return $! ()
    let localAddress = "127.0.0.1"
    let remoteAddress = "127.0.0.1"
    let remotePort = 43321
    newConnectionRef <- newIORef False

    let psd = PerSessionData forceConnectionClose
                             twiddleTimeout
                             newConnectionRef
                             (mockSendFileHandler writeEnd)
                             localAddress
                             80
                             remoteAddress
                             remotePort
                             readEnd
                             writeEnd

    return psd


------------------------------------------------------------------------------
-- | Make a pipe -- the two Input/OutputStream pairs will communicate with each
-- other from separate threads by using 'Chan's.
makePipe :: PipeFunc
makePipe = do
    chan1 <- newChan
    chan2 <- newChan

    clientReadEnd  <- Streams.chanToInput  chan1
    clientWriteEnd <- Streams.chanToOutput chan2 >>=
                      Streams.contramapM (evaluate . S.copy)
    serverReadEnd  <- Streams.chanToInput  chan2
    serverWriteEnd <- Streams.chanToOutput chan1 >>=
                      Streams.contramapM (evaluate . S.copy)

    return ((clientReadEnd, clientWriteEnd), (serverReadEnd, serverWriteEnd))


------------------------------------------------------------------------------
-- | Make a pipe -- the two Input/OutputStream pairs will communicate with each
-- other from separate threads by using 'Chan's. Data moving through the
-- streams will be logged to stdout.
_makeDebugPipe :: ByteString -> PipeFunc
_makeDebugPipe name = do
    chan1 <- newChan
    chan2 <- newChan

    clientReadEnd  <- Streams.chanToInput  chan1 >>=
                      Streams.debugInputBS (S.append name "/client-rd")
                                           Streams.stderr
    clientWriteEnd <- Streams.chanToOutput chan2 >>=
                      Streams.debugOutputBS (S.append name "/client-wr")
                                            Streams.stderr >>=
                      Streams.contramapM (evaluate . S.copy)
    serverReadEnd  <- Streams.chanToInput  chan2 >>=
                      Streams.debugInputBS (S.append name "/server-rd")
                                           Streams.stderr
    serverWriteEnd <- Streams.chanToOutput chan1 >>=
                      Streams.debugOutputBS (S.append name "/server-wr")
                                            Streams.stderr >>=
                      Streams.contramapM (evaluate . S.copy)

    return ((clientReadEnd, clientWriteEnd), (serverReadEnd, serverWriteEnd))


------------------------------------------------------------------------------
type PipeFunc = IO ( (InputStream ByteString, OutputStream ByteString)
                   , (InputStream ByteString, OutputStream ByteString)
                   )

------------------------------------------------------------------------------
-- | Given a bunch of requests, convert them to bytestrings and pipeline them
-- into the 'httpSession' code, recording the results.
runRequestPipeline :: [T.RequestBuilder IO ()]
                   -> Snap b
                   -> IO [(Http.Response, ByteString)]
runRequestPipeline = runRequestPipelineDebug makePipe


------------------------------------------------------------------------------
-- | Given a bunch of requests, convert them to bytestrings and pipeline them
-- into the 'httpSession' code, recording the results.
runRequestPipelineDebug :: PipeFunc
                        -> [T.RequestBuilder IO ()]
                        -> Snap b
                        -> IO [(Http.Response, ByteString)]
runRequestPipelineDebug pipeFunc rbs handler = dieIfTimeout $ do
    ((clientRead, clientWrite), (serverRead, serverWrite)) <- pipeFunc

    sigClient <- newEmptyMVar
    results   <- newMVar []

    forM_ rbs $ makeRequest >=> flip Streams.write clientWrite . Just
    Streams.write Nothing clientWrite

    myTid <- myThreadId
    conn <- Http.makeConnection "localhost"
                                (return ())
                                clientWrite
                                clientRead

    bracket (do ctid <- mask $ \restore ->
                        forkIO $ clientThread restore myTid clientRead conn
                                              results sigClient
                stid <- forkIO $ serverThread myTid serverRead serverWrite
                return (ctid, stid))
            (\(ctid, stid) -> mapM_ killThread [ctid, stid])
            (\_ -> await sigClient)
    readMVar results

  where
    await sig = takeMVar sig >>= either throwIO (const $ return ())

    serverThread myTid serverRead serverWrite = do
        runSession serverRead serverWrite handler
          `catch` \(e :: SomeException) -> throwTo myTid e

    clientThread restore myTid clientRead conn results sig =
        (try (restore loop) >>= putMVar (sig :: MVar (Either SomeException ())))
          `catch` \(e :: SomeException) -> throwTo myTid e

      where
        loop = do
            eof <- Streams.atEOF clientRead
            if eof
              then return ()
              else do
                (resp, body) <- Http.receiveResponse conn $ \rsp istr -> do
                    !out <- liftM S.concat $ Streams.toList istr
                    return (rsp, out)
                modifyMVar_ results (return . (++ [(resp, body)]))
                loop


------------------------------------------------------------------------------
getSessionOutput :: [ByteString]
                 -> Snap a
                 -> IO ByteString
getSessionOutput input snap = do
    is <- Streams.fromList input >>= Streams.mapM (evaluate . S.copy)
    (os0, getList) <- Streams.listOutputStream
    os <- Streams.contramapM (evaluate . S.copy) os0
    runSession is os snap
    liftM S.concat getList


------------------------------------------------------------------------------
runSession :: InputStream ByteString
           -> OutputStream ByteString
           -> Snap a
           -> IO ()
runSession readEnd writeEnd handler = do
    buffer         <- newBuffer 64000
    perSessionData <- makePerSessionData readEnd writeEnd
    httpSession buffer (snapToServerHandler handler)
                       (makeServerConfig ())
                       perSessionData
    Streams.write Nothing writeEnd


------------------------------------------------------------------------------
makeServerConfig :: hookState -> ServerConfig hookState
makeServerConfig hs = setOnException onEx                            .
                      setOnNewRequest onStart                        .
                      setLogError logErr                             .
                      setLogAccess logAccess                         .
                      setOnDataFinished onDataFinished               .
                      setOnEscape onEscape                           .
                      setOnUserHandlerFinished onUserHandlerFinished .
                      setDefaultTimeout 10                           .
                      setLocalHostname "backup-localhost"            .
                      setIsSecure False                              .
                      setNumAcceptLoops 1                            .
                      setOnParse onParse                             $
                      emptyServerConfig
  where
    onStart !psd = do
        void $ readIORef (_isNewConnection psd) >>= evaluate
        return hs

    logAccess !_ !_ !_             = return $! ()
    logErr !e                      = void $ evaluate $ toByteString e
    onParse !_ !_                  = return $! ()
    onUserHandlerFinished !_ !_ !_ = return $! ()
    onDataFinished !_ !_ !_        = return $! ()
    onEx !_ !e                     = throwIO e
    onEscape !_                    = return $! ()


------------------------------------------------------------------------------
listOutputStream :: IO (OutputStream ByteString, IO [ByteString])
listOutputStream = do
    (os, out) <- Streams.listOutputStream
    os' <- Streams.contramapM (evaluate . S.copy) os
    return (os', out)


------------------------------------------------------------------------------
data TestException = TestException
  deriving (Typeable, Show)
instance Exception TestException


------------------------------------------------------------------------------
data Result = SendFile ByteString FilePath Word64 Word64
            | Output ByteString
  deriving (Eq, Ord, Show)


------------------------------------------------------------------------------
runAcceptLoop :: [T.RequestBuilder IO ()]
              -> Snap a
              -> IO [Result]
runAcceptLoop requests snap = dieIfTimeout $ do
    -- make sure we don't log error on ThreadKilled.
    (_, errs') <- run afuncSuicide
    assertBool ("errs': " ++ show errs') $ null errs'

    -- make sure we gobble IOException.
    count <- newIORef 0
    (_, errs'') <- run $ afuncIOException count
    assertBool ("errs'': " ++ show errs'') $ length errs'' == 2

    liftM fst $ run acceptFunc

  where
    --------------------------------------------------------------------------
    run afunc = do
        reqStreams <- Streams.fromList requests >>=
                      Streams.mapM makeRequest >>=
                      Streams.lockingInputStream

        outputs  <- newMVar []
        lock     <- newMVar ()
        err      <- newMVar []

        httpAcceptLoop (snapToServerHandler snap) (config err) $
                       afunc reqStreams outputs lock

        out <- takeMVar outputs
        errs <- takeMVar err
        return (out, errs)

    --------------------------------------------------------------------------
    config mvar = (makeServerConfig ()) {
                    _logError = \b -> let !s = toByteString b
                                      in modifyMVar_ mvar $ \xs -> do
                                           void (evaluate s)
                                           return (xs ++ [s])
                  }

    --------------------------------------------------------------------------
    afuncSuicide :: InputStream ByteString
                 -> MVar [Result]
                 -> MVar ()
                 -> AcceptFunc
    afuncSuicide _ _ lock = AcceptFunc $ \restore ->
        restore $ withMVar lock (\_ -> throwIO ThreadKilled)

    --------------------------------------------------------------------------
    afuncIOException :: IORef Int
                     -> InputStream ByteString
                     -> MVar [Result]
                     -> MVar ()
                     -> AcceptFunc
    afuncIOException ref _ _ lock = AcceptFunc $ \restore ->
                                    restore $ withMVar lock $ const $ do
        x <- readIORef ref
        writeIORef ref $! x + 1
        if x >= 2
          then throwIO ThreadKilled
          else throwIO $ userError "hello"

    --------------------------------------------------------------------------
    acceptFunc :: InputStream ByteString
               -> MVar [Result]
               -> MVar ()
               -> AcceptFunc
    acceptFunc inputStream output lock = AcceptFunc $ \restore -> restore $ do
        void $ takeMVar lock
        b <- atEOF
        when b $ myThreadId >>= killThread
        os <- Streams.makeOutputStream out >>=
              Streams.contramap S.copy
        return (sendFileFunc, "localhost", 80, "localhost", 55555, inputStream,
                os, putMVar lock ())

      where
        atEOF = Streams.peek inputStream >>= maybe (return True) f
          where
            f x | S.null x  = do void $ Streams.read inputStream
                                 atEOF
                | otherwise = return False

        out (Just s) | S.null s = return ()
        out (Just s)            = modifyMVar_ output $ return . (++ [Output s])
        out Nothing             = return ()

        sendFileFunc !_ !bldr !fp !st !end =
          modifyMVar_ output $
          return . (++ [(SendFile (toByteString bldr) fp st end)])


------------------------------------------------------------------------------
dieIfTimeout :: IO a -> IO a
dieIfTimeout m = timeout (10 * seconds) m >>= maybe (error "timeout") return


------------------------------------------------------------------------------
seconds :: Int
seconds = (10::Int) ^ (6::Int)

------------------------------------------------------------------------------
toByteString :: Builder -> S.ByteString
toByteString = S.concat . L.toChunks . toLazyByteString