Blackbox.hs

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

module Test.Blackbox
  ( tests
  , haTests
  , ssltests
  , startTestServers
  ) where

--------------------------------------------------------------------------------
import           Control.Applicative                  ((<$>))
import           Control.Arrow                        (first)
import           Control.Concurrent                   (MVar, ThreadId, forkIO, forkIOWithUnmask, killThread, newEmptyMVar, putMVar, takeMVar, threadDelay, tryPutMVar)
import           Control.Exception                    (bracket, bracketOnError, finally, mask_)
import           Control.Monad                        (forM_, forever, void, when)
import qualified Data.ByteString.Base16               as B16
import           Data.ByteString.Builder              (byteString)
import           Data.ByteString.Char8                (ByteString)
import qualified Data.ByteString.Char8                as S
import qualified Data.ByteString.Lazy.Char8           as L
import           Data.CaseInsensitive                 (CI)
import qualified Data.CaseInsensitive                 as CI
import           Data.List                            (sort)
import           Data.Monoid                          (Monoid (mconcat, mempty))
import qualified Network.Http.Client                  as HTTP
import qualified Network.Http.Types                   as HTTP
import qualified Network.Socket                       as N
import qualified Network.Socket.ByteString            as NB
import           Prelude                              (Bool (..), Eq (..), IO, Int, Maybe (..), Show (..), String, concat, concatMap, const, dropWhile, elem, flip, fromIntegral, fst, head, id, map, mapM_, maybe, min, not, null, otherwise, putStrLn, replicate, return, reverse, uncurry, ($), ($!), (*), (++), (.), (^))
import qualified Prelude
------------------------------------------------------------------------------
#ifdef OPENSSL
import qualified OpenSSL.Session                      as SSL
#endif
import qualified System.IO.Streams                    as Streams
import           System.Timeout                       (timeout)
import           Test.Framework                       (Test, TestOptions' (topt_maximum_generated_tests), plusTestOptions)
import           Test.Framework.Providers.HUnit       (testCase)
import           Test.Framework.Providers.QuickCheck2 (testProperty)
import           Test.HUnit                           hiding (Test, path)
import           Test.QuickCheck                      (Arbitrary (arbitrary))
import           Test.QuickCheck.Monadic              (forAllM, monadicIO)
import qualified Test.QuickCheck.Monadic              as QC
import qualified Test.QuickCheck.Property             as QC
------------------------------------------------------------------------------
import           Snap.Internal.Debug                  (debug)
import           Snap.Internal.Http.Server.Session    (httpAcceptLoop, snapToServerHandler)
import qualified Snap.Internal.Http.Server.Socket     as Sock
import qualified Snap.Internal.Http.Server.TLS        as TLS
import qualified Snap.Internal.Http.Server.Types      as Types
import           Snap.Test.Common                     (ditchHeaders, eatException, expectExceptionBeforeTimeout, recvAll, timeoutIn, withSock)
import           Test.Common.Rot13                    (rot13)
import           Test.Common.TestHandler              (testHandler)


------------------------------------------------------------------------------
tests :: Int -> [Test]
tests port = map (\f -> f False port "") testFunctions

ssltests :: Maybe Int -> [Test]
ssltests = maybe [] httpsTests
    where httpsTests port = map (\f -> f True port sslname) testFunctions
          sslname = "ssl/"

haTests :: Int -> [Test]
haTests port = [ testHaProxy port
               , testHaProxyLocal port
               , testHaProxyFileServe port
               ]

testFunctions :: [Bool -> Int -> String -> Test]
testFunctions = [ testPong
-- FIXME: waiting on http-enumerator patch for HEAD behaviour
--                , testHeadPong
                , testEcho
                , testRot13
                , testSlowLoris
                , testBlockingRead
                , testBigResponse
                , testPartial
                , testFileUpload
                , testTimeoutTickle
                , testHasDateHeader
                , testServerHeader
                , testFileServe
                , testTimelyRedirect
                , testChunkedHead
                ]

------------------------------------------------------------------------------
startServer :: Types.ServerConfig hookState
            -> IO a
            -> (a -> N.Socket)
            -> (a -> Types.AcceptFunc)
            -> IO (ThreadId, Int, MVar ())
startServer config bind projSock afunc =
    bracketOnError bind (N.close . projSock) forkServer
  where
    forkServer a = do
        mv <- newEmptyMVar
        port <- fromIntegral <$> N.socketPort (projSock a)
        tid <- forkIO $
               eatException $
               (httpAcceptLoop (snapToServerHandler testHandler)
                               config
                               (afunc a)
                  `finally` putMVar mv ())
        return (tid, port, mv)


------------------------------------------------------------------------------
-- | Returns the thread the server is running in as well as the port it is
-- listening on.
data TestServerType = NormalTest | ProxyTest | SSLTest
  deriving (Show)

startTestSocketServer :: TestServerType -> IO (ThreadId, Int, MVar ())
startTestSocketServer serverType = do
  putStrLn $ "Blackbox: starting " ++ show serverType ++ " server"
  case serverType of
    NormalTest -> startServer emptyServerConfig bindSock id Sock.httpAcceptFunc
    ProxyTest  -> startServer emptyServerConfig bindSock id Sock.haProxyAcceptFunc
    SSLTest    -> startServer emptyServerConfig bindSSL fst
                              (uncurry TLS.httpsAcceptFunc)
  where
#if MIN_VERSION_network(2,7,0)
    anyport = N.defaultPort
#else
    anyport = N.aNY_PORT
#endif

    bindSSL = do
        sockCtx <- TLS.bindHttps "127.0.0.1"
                                 (fromIntegral anyport)
                                 "test/cert.pem"
                                 False
                                 "test/key.pem"
                                 Nothing
#ifdef OPENSSL
        -- Set client code not to verify
        HTTP.modifyContextSSL $ \ctx -> do
            SSL.contextSetVerificationMode ctx SSL.VerifyNone
            return ctx
#endif
        return sockCtx

    bindSock = Sock.bindSocket "127.0.0.1" (fromIntegral anyport)

    logAccess !_ !_ !_             = return ()
    logError !_                    = return ()
    onStart !_                     = return ()
    onParse !_ !_                  = return ()
    onUserHandlerFinished !_ !_ !_ = return ()
    onDataFinished !_ !_ !_        = return ()
    onExceptionHook !_ !_          = return ()
    onEscape !_                    = return ()

    emptyServerConfig = Types.ServerConfig logAccess
                                           logError
                                           onStart
                                           onParse
                                           onUserHandlerFinished
                                           onDataFinished
                                           onExceptionHook
                                           onEscape
                                           "localhost"
                                           6
                                           False
                                           1


------------------------------------------------------------------------------
waitabit :: IO ()
waitabit = threadDelay $ 2*seconds


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


------------------------------------------------------------------------------
fetch :: ByteString -> IO ByteString
fetch url = HTTP.get url HTTP.concatHandler'


------------------------------------------------------------------------------
fetchWithHeaders :: ByteString
                 -> IO (ByteString, [(CI ByteString, ByteString)])
fetchWithHeaders url = HTTP.get url h
  where
    h resp is = do
        let hdrs = map (first CI.mk) $ HTTP.retrieveHeaders $ HTTP.getHeaders resp
        body <- HTTP.concatHandler' resp is
        return (body, hdrs)


------------------------------------------------------------------------------
slowTestOptions :: Bool -> TestOptions' Maybe
slowTestOptions ssl =
    if ssl
      then mempty { topt_maximum_generated_tests = Just 75 }
      else mempty { topt_maximum_generated_tests = Just 300 }


------------------------------------------------------------------------------
-- FIXME: waiting on http-enumerator patch for HEAD behaviour
-- headPong :: Bool -> Int -> IO ByteString
-- headPong ssl port = do
--     let uri = (if ssl then "https" else "http")
--               ++ "://127.0.0.1:" ++ show port ++ "/echo"

--     req0 <- HTTP.parseUrl uri

--     let req = req0 { HTTP.method = "HEAD" }
--     rsp <- HTTP.httpLbs req
--     return $ S.concat $ L.toChunks $ HTTP.responseBody rsp


------------------------------------------------------------------------------
-- FIXME: waiting on http-enumerator patch for HEAD behaviour
-- testHeadPong :: Bool -> Int -> String -> Test
-- testHeadPong ssl port name = testCase (name ++ "blackbox/pong/HEAD") $ do
--     doc <- headPong ssl port
--     assertEqual "pong HEAD response" "" doc


------------------------------------------------------------------------------
-- TODO: doesn't work w/ ssl
testBlockingRead :: Bool -> Int -> String -> Test
testBlockingRead ssl port name =
    testCase (name ++ "blackbox/testBlockingRead") $
             if ssl then return () else runIt

  where
    runIt = withSock port $ \sock -> do
        m <- timeout (60*seconds) $ go sock
        maybe (assertFailure "timeout")
              (const $ return ())
              m

    go sock = do
        NB.sendAll sock "GET /"
        waitabit
        NB.sendAll sock "pong HTTP/1.1\r\n"
        NB.sendAll sock "Host: 127.0.0.1\r\n"
        NB.sendAll sock "Content-Length: 0\r\n"
        NB.sendAll sock "Connection: close\r\n\r\n"

        resp <- recvAll sock

        let s = head $ ditchHeaders $ S.lines resp

        assertEqual "pong response" "PONG" s


------------------------------------------------------------------------------
-- TODO: this one doesn't work w/ SSL
testSlowLoris :: Bool -> Int -> String -> Test
testSlowLoris ssl port name = testCase (name ++ "blackbox/slowloris") $
                              if ssl then return () else withSock port go

  where
    go sock = do
        NB.sendAll sock "POST /echo HTTP/1.1\r\n"
        NB.sendAll sock "Host: 127.0.0.1\r\n"
        NB.sendAll sock "Content-Length: 2500000\r\n"
        NB.sendAll sock "Connection: close\r\n\r\n"

        b <- expectExceptionBeforeTimeout (loris sock) 30

        assertBool "didn't catch slow loris attack" b

    loris sock = forever $ do
        NB.sendAll sock "."
        waitabit


------------------------------------------------------------------------------
testRot13 :: Bool -> Int -> String -> Test
testRot13 ssl port name =
    plusTestOptions (slowTestOptions ssl) $
    testProperty (name ++ "blackbox/rot13") $
    monadicIO $ forAllM arbitrary prop
  where
    prop txt = do
        let uri = (if ssl then "https" else "http")
                  ++ "://127.0.0.1:" ++ show port ++ "/rot13"

        doc <- QC.run $ HTTP.post (S.pack uri) "text/plain"
                                  (Streams.write (Just $ byteString txt))
                                  HTTP.concatHandler'
        QC.assert $ txt == rot13 doc


------------------------------------------------------------------------------
doPong :: Bool -> Int -> IO ByteString
doPong ssl port = do
    debug "getting URI"
    let !uri = (if ssl then "https" else "http")
               ++ "://127.0.0.1:" ++ show port ++ "/pong"
    debug $ "URI is: '" ++ uri ++ "', calling simpleHttp"

    rsp <- fetch $ S.pack uri

    debug $ "response was " ++ show rsp
    return rsp


------------------------------------------------------------------------------
testPong :: Bool -> Int -> String -> Test
testPong ssl port name = testCase (name ++ "blackbox/pong") $ do
    doc <- doPong ssl port
    assertEqual "pong response" "PONG" doc


------------------------------------------------------------------------------
testHasDateHeader :: Bool -> Int -> String -> Test
testHasDateHeader ssl port name = testCase (name ++ "blackbox/hasDateHdr") $ do
    let !url = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port
                   ++ "/pong"
    (rsp, hdrs) <- fetchWithHeaders $ S.pack url

    let hasDate = "date" `elem` map fst hdrs
    when (not hasDate) $ do
        putStrLn "server not sending dates:"
        forM_ hdrs $ \(k,v) -> S.putStrLn $ S.concat [CI.original k, ": ", v]
    assertBool "has date" hasDate
    assertEqual "pong response" "PONG" rsp


------------------------------------------------------------------------------
testChunkedHead :: Bool -> Int -> String -> Test
testChunkedHead ssl port name = testCase (name ++ "blackbox/chunkedHead") $
                                if ssl then return () else withSock port go
  where
    go sock = do
        NB.sendAll sock $ S.concat [ "HEAD /chunked HTTP/1.1\r\n"
                                   , "Host: localhost\r\n"
                                   , "\r\n"
                                   ]
        s <- NB.recv sock 4096
        assertBool (concat [ "no body: received '"
                           , S.unpack s
                           , "'" ]) $ isOK s

    split x l | S.null x  = reverse l
              | otherwise = let (a, b) = S.break (== '\r') x
                                b'     = S.drop 2 b
                            in split b' (a : l)

    isOK s = let lns  = split s []
                 lns' = Prelude.drop 1 $ dropWhile (not . S.null) lns
             in null lns'


------------------------------------------------------------------------------
-- TODO: no ssl here
-- test server's ability to trap/recover from IO errors
testPartial :: Bool -> Int -> String -> Test
testPartial ssl port name =
    testCase (name ++ "blackbox/testPartial") $
    if ssl then return () else runIt

  where
    runIt = do
        m <- timeout (60*seconds) go
        maybe (assertFailure "timeout")
              (const $ return ())
              m

    go = do
        withSock port $ \sock ->
            NB.sendAll sock "GET /pong HTTP/1.1\r\n"

        doc <- doPong ssl port
        assertEqual "pong response" "PONG" doc


------------------------------------------------------------------------------
-- TODO: no ssl here
-- test server's ability to trap/recover from IO errors
testTimelyRedirect :: Bool -> Int -> String -> Test
testTimelyRedirect ssl port name =
    testCase (name ++ "blackbox/testTimelyRedirect") $
    if ssl then return () else runIt

  where
    runIt = do
        m <- timeout (5*seconds) go
        maybe (assertFailure "timeout")
              (const $ return ())
              m

    go = do
        withSock port $ \sock -> do
            NB.sendAll sock $ S.concat [ "GET /redirect HTTP/1.1\r\n"
                                      , "Host: localhost\r\n\r\n" ]
            resp <- NB.recv sock 100000
            assertBool "wasn't code 302" $ S.isInfixOf "302" resp
            assertBool "didn't have content length" $
                S.isInfixOf "content-length: 0" resp


------------------------------------------------------------------------------
-- TODO: no ssl
testBigResponse :: Bool -> Int -> String -> Test
testBigResponse ssl port name =
    testCase (name ++ "blackbox/testBigResponse") $
    if ssl then return () else runIt
  where
    runIt = withSock port $ \sock -> do
        m <- timeout (120*seconds) $ go sock
        maybe (assertFailure "timeout")
              (const $ return ())
              m

    go sock = do
        NB.sendAll sock "GET /bigresponse HTTP/1.1\r\n"
        NB.sendAll sock "Host: 127.0.0.1\r\n"
        NB.sendAll sock "Content-Length: 0\r\n"
        NB.sendAll sock "Connection: close\r\n\r\n"

        let body = S.replicate 4000000 '.'
        resp <- recvAll sock

        let s = head $ ditchHeaders $ S.lines resp

        assertBool "big response" $ body == s


------------------------------------------------------------------------------
testHaProxy :: Int -> Test
testHaProxy port = testCase "blackbox/haProxy" runIt

  where
    runIt = withSock port $ \sock -> do
        m <- timeout (120*seconds) $ go sock
        maybe (assertFailure "timeout")
              (const $ return ())
              m

    go sock = do
        NB.sendAll sock $ S.concat
              [ "PROXY TCP4 1.2.3.4 5.6.7.8 1234 5678\r\n"
              , "GET /remoteAddrPort HTTP/1.1\r\n"
              , "Host: 127.0.0.1\r\n"
              , "Content-Length: 0\r\n"
              , "Connection: close\r\n\r\n"
              ]

        resp <- recvAll sock

        let s = head $ ditchHeaders $ S.lines resp

        when (s /= "1.2.3.4:1234") $ S.putStrLn s
        assertEqual "haproxy response" "1.2.3.4:1234" s


------------------------------------------------------------------------------
testHaProxyFileServe :: Int -> Test
testHaProxyFileServe port = testCase "blackbox/haProxyFileServe" runIt
  where
    runIt = withSock port $ \sock -> do
        m <- timeout (120*seconds) $ go sock
        maybe (assertFailure "timeout")
              (const $ return ())
              m

    go sock = do
        NB.sendAll sock $ S.concat
              [ "PROXY UNKNOWN\r\n"
              , "GET /fileserve/hello.txt HTTP/1.1\r\n"
              , "Host: 127.0.0.1\r\n"
              , "Content-Length: 0\r\n"
              , "Connection: close\r\n\r\n"
              ]

        resp <- recvAll sock

        let s = head $ ditchHeaders $ S.lines resp

        assertEqual "haproxy response" "hello world" s


------------------------------------------------------------------------------
testHaProxyLocal :: Int -> Test
testHaProxyLocal port = testCase "blackbox/haProxyLocal" runIt

  where
#if MIN_VERSION_network(2,7,0)
    anyport = N.defaultPort
#else
    anyport = N.aNY_PORT
#endif

    remoteAddrServer :: N.Socket
                     -> MVar (Maybe String)
                     -> (forall a . IO a -> IO a)
                     -> IO ()
    remoteAddrServer ssock mvar restore =
      timeoutIn 10 $
      flip finally (tryPutMVar mvar Nothing) $
      bracket (restore $ N.accept ssock)
              (eatException . N.close . fst)
              (\(_, peer) -> putMVar mvar $! Just $! show peer)

    slurp p input = timeoutIn 10 $ withSock p
                      $ \sock -> do NB.sendAll sock input
                                    recvAll sock

    determineSourceInterfaceAddr =
        timeoutIn 10 $
        bracket
          (Sock.bindSocket "127.0.0.1" (fromIntegral anyport))
          (eatException . N.close)
          (\ssock -> do
             mv      <- newEmptyMVar
             svrPort <- fromIntegral <$> N.socketPort ssock
             bracket (mask_ $ forkIOWithUnmask $ remoteAddrServer ssock mv)
                     (eatException . killThread)
                     (const $ do void $ slurp svrPort ""
                                 (Just s) <- takeMVar mv
                                 return $! fst $ S.breakEnd (==':') $ S.pack s))

    runIt = do
        saddr <- determineSourceInterfaceAddr
        resp <- slurp port $ S.concat
                  [ "PROXY UNKNOWN\r\n"
                  , "GET /remoteAddrPort HTTP/1.1\r\n"
                  , "Host: 127.0.0.1\r\n"
                  , "Content-Length: 0\r\n"
                  , "Connection: close\r\n\r\n"
                  ]

        let s = head $ ditchHeaders $ S.lines resp

        when (not $ S.isPrefixOf saddr s) $ S.putStrLn s
        assertBool "haproxy response" $ S.isPrefixOf saddr s


------------------------------------------------------------------------------
-- This test checks two things:
--
-- 1. that the timeout tickling logic works
-- 2. that "flush" is passed along through a gzip operation.
testTimeoutTickle :: Bool -> Int -> String -> Test
testTimeoutTickle ssl port name =
    testCase (name ++ "blackbox/timeout/tickle") $ do
        let uri = (if ssl then "https" else "http")
                  ++ "://127.0.0.1:" ++ show port ++ "/timeout/tickle"
        doc <- fetch $ S.pack uri
        let expected = S.concat $ replicate 10 ".\n"
        assertEqual "response equal" expected doc


------------------------------------------------------------------------------
testFileServe :: Bool -> Int -> String -> Test
testFileServe ssl port name =
    testCase (name ++ "blackbox/fileserve") $ do
        let uri = (if ssl then "https" else "http")
                  ++ "://127.0.0.1:" ++ show port ++ "/fileserve/hello.txt"
        doc <- fetch $ S.pack uri
        let expected = "hello world\n"
        assertEqual "response equal" expected doc


------------------------------------------------------------------------------
testFileUpload :: Bool -> Int -> String -> Test
testFileUpload ssl port name =
    plusTestOptions (slowTestOptions ssl) $
    testProperty (name ++ "blackbox/upload") $
    QC.mapSize (if ssl then min 100 else min 300) $
    monadicIO $
    forAllM arbitrary prop
  where
    boundary = "boundary-jdsklfjdsalkfjadlskfjldskjfldskjfdsfjdsklfldksajfl"

    prefix = [ "--"
             , boundary
             , "\r\n"
             , "content-disposition: form-data; name=\"submit\"\r\n"
             , "\r\nSubmit\r\n" ]

    body kvps = L.concat $ prefix ++ concatMap part kvps ++ suffix
      where
        part (k,v) = [ "--"
                     , boundary
                     , "\r\ncontent-disposition: attachment; filename=\""
                     , k
                     , "\"\r\nContent-Type: text/plain\r\n\r\n"
                     , v
                     , "\r\n" ]

    suffix = [ "--", boundary, "--\r\n" ]

    hdrs = [ ("Content-type", S.concat $ [ "multipart/form-data; boundary=" ]
                                         ++ L.toChunks boundary) ]

    b16 (k,v) = (ne $ e k, e v)
      where
        ne s = if L.null s then "file" else s
        e s = L.fromChunks [ B16.encode $ S.concat $ L.toChunks s ]

    response kvps = L.concat $ [ "Param:\n"
                               , "submit\n"
                               , "Value:\n"
                               , "Submit\n\n" ] ++ concatMap responseKVP kvps

    responseKVP (k,v) = [ "File:\n"
                        , k
                        , "\nValue:\n"
                        , v
                        , "\n\n" ]

    prop kvps' = do
        let kvps = sort $ map b16 kvps'

        let uri = S.pack $ concat [ if ssl then "https" else "http"
                                  , "://127.0.0.1:"
                                  , show port
                                  , "/upload/handle" ]

        let txt = response kvps
        doc0 <- QC.run
                  $ HTTP.withConnection (HTTP.establishConnection uri)
                  $ \conn -> do
            req <- HTTP.buildRequest $ do
                HTTP.http HTTP.POST uri
                mapM_ (uncurry HTTP.setHeader) hdrs

            HTTP.sendRequest conn req (Streams.write $ Just
                                                     $ mconcat
                                                     $ map byteString
                                                     $ L.toChunks
                                                     $ body kvps)
            HTTP.receiveResponse conn HTTP.concatHandler'

        let doc = L.fromChunks [doc0]
        when (txt /= doc) $ QC.run $ do
                     L.putStrLn "expected:"
                     L.putStrLn "----------------------------------------"
                     L.putStrLn txt
                     L.putStrLn "----------------------------------------"
                     L.putStrLn "\ngot:"
                     L.putStrLn "----------------------------------------"
                     L.putStrLn doc
                     L.putStrLn "----------------------------------------"

        QC.assert $ txt == doc


------------------------------------------------------------------------------
testEcho :: Bool -> Int -> String -> Test
testEcho ssl port name =
    plusTestOptions (slowTestOptions ssl) $
    testProperty (name ++ "blackbox/echo") $
    QC.mapSize (if ssl then min 100 else min 300) $
    monadicIO $ forAllM arbitrary prop
  where
    prop txt = do
        let uri = (if ssl then "https" else "http")
                  ++ "://127.0.0.1:" ++ show port ++ "/echo"

        doc <- QC.run $ HTTP.post (S.pack uri) "text/plain"
                                  (Streams.write (Just $ byteString txt))
                                  HTTP.concatHandler'
        QC.assert $ txt == doc


------------------------------------------------------------------------------
testServerHeader :: Bool -> Int -> String -> Test
testServerHeader ssl port name =
    testCase (name ++ "blackbox/server-header") $ do
        let uri = (if ssl then "https" else "http")
                  ++ "://127.0.0.1:" ++ show port ++ "/server-header"
        HTTP.get (S.pack uri) $ \resp _ -> do
            let serverHeader = HTTP.getHeader resp "server"
            assertEqual "server header" (Just "foo") serverHeader


------------------------------------------------------------------------------
startTestServers :: IO ((ThreadId, Int, MVar ()),
                        (ThreadId, Int, MVar ()),
                        Maybe (ThreadId, Int, MVar ()))
startTestServers = do
    x <- startTestSocketServer NormalTest
    y <- startTestSocketServer ProxyTest
#ifdef OPENSSL
    z <- startTestSocketServer SSLTest
    return (x, y, Just z)
#else
    return (x, y, Nothing)
#endif