wai-extra-1.3.0.2: test/WaiExtraTest.hs

{-# LANGUAGE OverloadedStrings #-}
module WaiExtraTest (specs) where

import Test.Hspec
import Test.HUnit hiding (Test)

import Network.Wai
import Network.Wai.Test
import Network.Wai.Parse
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.ByteString.Lazy as L
import qualified Data.Text.Lazy as T
import qualified Data.Text.Encoding as TE
import Control.Arrow

import Network.Wai.Middleware.Jsonp
import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.Vhost
import Network.Wai.Middleware.Autohead
import Network.Wai.Middleware.MethodOverride
import Network.Wai.Middleware.MethodOverridePost
import Network.Wai.Middleware.AcceptOverride
import Network.Wai.Middleware.RequestLogger
import Codec.Compression.GZip (decompress)

import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import Data.Conduit.Binary (sourceFile)
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (fromMaybe)
import Network.HTTP.Types (parseSimpleQuery, status200)
import System.Log.FastLogger

import qualified Data.IORef as I

specs :: Spec
specs = do
  describe "Network.Wai.Parse" $ do
    it "parseQueryString" caseParseQueryString
    it "parseQueryString with question mark" caseParseQueryStringQM
    it "parseHttpAccept" caseParseHttpAccept
    it "parseRequestBody" caseParseRequestBody
    it "multipart with plus" caseMultipartPlus
    it "urlencoded with plus" caseUrlEncPlus
    {-
    , it "findBound" caseFindBound
    , it "sinkTillBound" caseSinkTillBound
    , it "killCR" caseKillCR
    , it "killCRLF" caseKillCRLF
    , it "takeLine" caseTakeLine
    -}
    it "jsonp" caseJsonp
    it "gzip" caseGzip
    it "gzip not for MSIE" caseGzipMSIE
    it "vhost" caseVhost
    it "autohead" caseAutohead
    it "method override" caseMethodOverride
    it "method override post" caseMethodOverridePost
    it "accept override" caseAcceptOverride
    it "dalvik multipart" caseDalvikMultipart
    it "debug request body" caseDebugRequestBody

caseParseQueryString :: Assertion
caseParseQueryString = do
    let go l r =
            map (S8.pack *** S8.pack) l @=? parseSimpleQuery (S8.pack r)

    go [] ""
    go [("foo", "")] "foo"
    go [("foo", "bar")] "foo=bar"
    go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin"
    go [("%Q", "")] "%Q"
    go [("%1Q", "")] "%1Q"
    go [("%1", "")] "%1"
    go [("/", "")] "%2F"
    go [("/", "")] "%2f"
    go [("foo bar", "")] "foo+bar"

caseParseQueryStringQM :: Assertion
caseParseQueryStringQM = do
    let go l r =
            map (S8.pack *** S8.pack) l
                @=? parseSimpleQuery (S8.pack $ '?' : r)

    go [] ""
    go [("foo", "")] "foo"
    go [("foo", "bar")] "foo=bar"
    go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin"
    go [("%Q", "")] "%Q"
    go [("%1Q", "")] "%1Q"
    go [("%1", "")] "%1"
    go [("/", "")] "%2F"
    go [("/", "")] "%2f"
    go [("foo bar", "")] "foo+bar"

caseParseHttpAccept :: Assertion
caseParseHttpAccept = do
    let input = "text/plain; q=0.5, text/html, text/x-dvi; q=0.8, text/x-c"
        expected = ["text/html", "text/x-c", "text/x-dvi", "text/plain"]
    expected @=? parseHttpAccept input

parseRequestBody' :: BackEnd L.ByteString
                  -> SRequest
                  -> C.ResourceT IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)])
parseRequestBody' sink (SRequest req bod) =
    case getRequestBodyType req of
        Nothing -> return ([], [])
        Just rbt -> CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody sink rbt

caseParseRequestBody :: Assertion
caseParseRequestBody =
    C.runResourceT t
  where
    content2 = S8.pack $
        "--AaB03x\n" ++
        "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n" ++
        "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
        "This is a file.\n" ++
        "It has two lines.\n" ++
        "--AaB03x\n" ++
        "Content-Disposition: form-data; name=\"title\"\n" ++
        "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
        "A File\n" ++
        "--AaB03x\n" ++
        "Content-Disposition: form-data; name=\"summary\"\n" ++
        "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
        "This is my file\n" ++
        "file test\n" ++
        "--AaB03x--"
    content3 = S8.pack "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\nContent-Disposition: form-data; name=\"yaml\"; filename=\"README\"\r\nContent-Type: application/octet-stream\r\n\r\nPhoto blog using Hack.\n\r\n------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n"
    t = do
        let content1 = "foo=bar&baz=bin"
        let ctype1 = "application/x-www-form-urlencoded"
        result1 <- parseRequestBody' lbsBackEnd $ toRequest ctype1 content1
        liftIO $ assertEqual "parsing post x-www-form-urlencoded"
                    (map (S8.pack *** S8.pack) [("foo", "bar"), ("baz", "bin")], [])
                    result1

        let ctype2 = "multipart/form-data; boundary=AaB03x"
        result2 <- parseRequestBody' lbsBackEnd $ toRequest ctype2 content2
        let expectedsmap2 =
              [ ("title", "A File")
              , ("summary", "This is my file\nfile test")
              ]
        let textPlain = S8.pack $ "text/plain; charset=iso-8859-1"
        let expectedfile2 =
              [(S8.pack "document", FileInfo (S8.pack "b.txt") textPlain $ L8.pack
                 "This is a file.\nIt has two lines.")]
        let expected2 = (map (S8.pack *** S8.pack) expectedsmap2, expectedfile2)
        liftIO $ assertEqual "parsing post multipart/form-data"
                    expected2
                    result2

        let ctype3 = "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"
        result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3
        let expectedsmap3 = []
        let expectedfile3 = [(S8.pack "yaml", FileInfo (S8.pack "README") (S8.pack "application/octet-stream") $
                                L8.pack "Photo blog using Hack.\n")]
        let expected3 = (expectedsmap3, expectedfile3)
        liftIO $ assertEqual "parsing actual post multipart/form-data"
                    expected3
                    result3

        result2' <- parseRequestBody' lbsBackEnd $ toRequest' ctype2 content2
        liftIO $ assertEqual "parsing post multipart/form-data 2"
                    expected2
                    result2'

        result3' <- parseRequestBody' lbsBackEnd $ toRequest' ctype3 content3
        liftIO $ assertEqual "parsing actual post multipart/form-data 2"
                    expected3
                    result3'

caseMultipartPlus :: Assertion
caseMultipartPlus = do
    result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content
    liftIO $ result @?= ([("email", "has+plus")], [])
  where
    content = S8.pack $
        "--AaB03x\n" ++
        "Content-Disposition: form-data; name=\"email\"\n" ++
        "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
        "has+plus\n" ++
        "--AaB03x--"
    ctype = "multipart/form-data; boundary=AaB03x"

caseUrlEncPlus :: Assertion
caseUrlEncPlus = do
    result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content
    liftIO $ result @?= ([("email", "has+plus")], [])
  where
    content = S8.pack $ "email=has%2Bplus"
    ctype = "application/x-www-form-urlencoded"

toRequest :: S8.ByteString -> S8.ByteString -> SRequest
toRequest ctype content = SRequest defaultRequest
    { requestHeaders = [("Content-Type", ctype)]
    , requestMethod = "POST"
    , rawPathInfo = "/"
    , rawQueryString = ""
    , queryString = []
    } (L.fromChunks [content])

toRequest' :: S8.ByteString -> S8.ByteString -> SRequest
toRequest' ctype content = SRequest defaultRequest
    { requestHeaders = [("Content-Type", ctype)]
    } (L.fromChunks $ map S.singleton $ S.unpack content)

{-
caseFindBound :: Assertion
caseFindBound = do
    findBound (S8.pack "def") (S8.pack "abcdefghi") @?=
        FoundBound (S8.pack "abc") (S8.pack "ghi")
    findBound (S8.pack "def") (S8.pack "ABC") @?= NoBound
    findBound (S8.pack "def") (S8.pack "abcd") @?= PartialBound
    findBound (S8.pack "def") (S8.pack "abcdE") @?= NoBound
    findBound (S8.pack "def") (S8.pack "abcdEdef") @?=
        FoundBound (S8.pack "abcdE") (S8.pack "")

caseSinkTillBound :: Assertion
caseSinkTillBound = do
    let iter () _ = return ()
    let src = S8.pack "this is some text"
        bound1 = S8.pack "some"
        bound2 = S8.pack "some!"
    let enum = enumList 1 [src]
    let helper _ _ = return ()
    (_, res1) <- run_ $ enum $$ sinkTillBound bound1 helper ()
    res1 @?= True
    (_, res2) <- run_ $ enum $$ sinkTillBound bound2 helper ()
    res2 @?= False

caseKillCR :: Assertion
caseKillCR = do
    "foo" @=? killCR "foo"
    "foo" @=? killCR "foo\r"
    "foo\r\n" @=? killCR "foo\r\n"
    "foo\r'" @=? killCR "foo\r'"

caseKillCRLF :: Assertion
caseKillCRLF = do
    "foo" @=? killCRLF "foo"
    "foo\r" @=? killCRLF "foo\r"
    "foo" @=? killCRLF "foo\r\n"
    "foo\r'" @=? killCRLF "foo\r'"
    "foo" @=? killCRLF "foo\n"

caseTakeLine :: Assertion
caseTakeLine = do
    helper "foo\nbar\nbaz" "foo"
    helper "foo\r\nbar\nbaz" "foo"
    helper "foo\nbar\r\nbaz" "foo"
    helper "foo\rbar\r\nbaz" "foo\rbar"
  where
    helper haystack needle = do
        x <- run_ $ enumList 1 [haystack] $$ takeLine
        Just needle @=? x
-}

jsonpApp :: Application
jsonpApp = jsonp $ const $ return $ responseLBS
    status200
    [("Content-Type", "application/json")]
    "{\"foo\":\"bar\"}"

caseJsonp :: Assertion
caseJsonp = flip runSession jsonpApp $ do
    sres1 <- request defaultRequest
                { queryString = [("callback", Just "test")]
                , requestHeaders = [("Accept", "text/javascript")]
                }
    assertContentType "text/javascript" sres1
    assertBody "test({\"foo\":\"bar\"})" sres1

    sres2 <- request defaultRequest
                { queryString = [("call_back", Just "test")]
                , requestHeaders = [("Accept", "text/javascript")]
                }
    assertContentType "application/json" sres2
    assertBody "{\"foo\":\"bar\"}" sres2

    sres3 <- request defaultRequest
                { queryString = [("callback", Just "test")]
                , requestHeaders = [("Accept", "text/html")]
                }
    assertContentType "application/json" sres3
    assertBody "{\"foo\":\"bar\"}" sres3

gzipApp :: Application
gzipApp = gzip def $ const $ return $ responseLBS status200
    [("Content-Type", "text/plain")]
    "test"

caseGzip :: Assertion
caseGzip = flip runSession gzipApp $ do
    sres1 <- request defaultRequest
                { requestHeaders = [("Accept-Encoding", "gzip")]
                }
    assertHeader "Content-Encoding" "gzip" sres1
    liftIO $ decompress (simpleBody sres1) @?= "test"

    sres2 <- request defaultRequest
                { requestHeaders = []
                }
    assertNoHeader "Content-Encoding" sres2
    assertBody "test" sres2

caseGzipMSIE :: Assertion
caseGzipMSIE = flip runSession gzipApp $ do
    sres1 <- request defaultRequest
                { requestHeaders =
                    [ ("Accept-Encoding", "gzip")
                    , ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)")
                    ]
                }
    assertNoHeader "Content-Encoding" sres1
    liftIO $ simpleBody sres1 @?= "test"

vhostApp1, vhostApp2, vhostApp :: Application
vhostApp1 = const $ return $ responseLBS status200 [] "app1"
vhostApp2 = const $ return $ responseLBS status200 [] "app2"
vhostApp = vhost
    [ ((== "foo.com") . serverName, vhostApp1)
    ]
    vhostApp2

caseVhost :: Assertion
caseVhost = flip runSession vhostApp $ do
    sres1 <- request defaultRequest
                { serverName = "foo.com"
                }
    assertBody "app1" sres1

    sres2 <- request defaultRequest
                { serverName = "bar.com"
                }
    assertBody "app2" sres2

autoheadApp :: Application
autoheadApp = autohead $ const $ return $ responseLBS status200
    [("Foo", "Bar")] "body"

caseAutohead :: Assertion
caseAutohead = flip runSession autoheadApp $ do
    sres1 <- request defaultRequest
                { requestMethod = "GET"
                }
    assertHeader "Foo" "Bar" sres1
    assertBody "body" sres1

    sres2 <- request defaultRequest
                { requestMethod = "HEAD"
                }
    assertHeader "Foo" "Bar" sres2
    assertBody "" sres2

moApp :: Application
moApp = methodOverride $ \req -> return $ responseLBS status200
    [("Method", requestMethod req)] ""

caseMethodOverride :: Assertion
caseMethodOverride = flip runSession moApp $ do
    sres1 <- request defaultRequest
                { requestMethod = "GET"
                , queryString = []
                }
    assertHeader "Method" "GET" sres1

    sres2 <- request defaultRequest
                { requestMethod = "POST"
                , queryString = []
                }
    assertHeader "Method" "POST" sres2

    sres3 <- request defaultRequest
                { requestMethod = "POST"
                , queryString = [("_method", Just "PUT")]
                }
    assertHeader "Method" "PUT" sres3

mopApp :: Application
mopApp = methodOverridePost $ \req -> return $ responseLBS status200 [("Method", requestMethod req)] ""

caseMethodOverridePost :: Assertion
caseMethodOverridePost = flip runSession mopApp $ do

    -- Get Request are unmodified
    sres1 <- let r = toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"
                 s = simpleRequest r
                 m = s { requestMethod = "GET" }
                 b = r { simpleRequest = m }
             in srequest b
    assertHeader "Method" "GET" sres1

    -- Post requests are modified if _method comes first
    sres2 <- srequest $ toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"
    assertHeader "Method" "PUT" sres2

    -- Post requests are unmodified if _method doesn't come first
    sres3 <- srequest $ toRequest "application/x-www-form-urlencoded" "foo=bar&_method=PUT&baz=bin"
    assertHeader "Method" "POST" sres3

    -- Post requests are unmodified if Content-Type header isn't set to "application/x-www-form-urlencoded"
    sres4 <- srequest $ toRequest "text/html; charset=utf-8" "foo=bar&_method=PUT&baz=bin"
    assertHeader "Method" "POST" sres4

aoApp :: Application
aoApp = acceptOverride $ \req -> return $ responseLBS status200
    [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""

caseAcceptOverride :: Assertion
caseAcceptOverride = flip runSession aoApp $ do
    sres1 <- request defaultRequest
                { queryString = []
                , requestHeaders = [("Accept", "foo")]
                }
    assertHeader "Accept" "foo" sres1

    sres2 <- request defaultRequest
                { queryString = []
                , requestHeaders = [("Accept", "bar")]
                }
    assertHeader "Accept" "bar" sres2

    sres3 <- request defaultRequest
                { queryString = [("_accept", Just "baz")]
                , requestHeaders = [("Accept", "bar")]
                }
    assertHeader "Accept" "baz" sres3

caseDalvikMultipart :: Assertion
caseDalvikMultipart = do
    let headers =
            [ ("content-length", "12098")
            , ("content-type", "multipart/form-data;boundary=*****")
            , ("GATEWAY_INTERFACE", "CGI/1.1")
            , ("PATH_INFO", "/")
            , ("QUERY_STRING", "")
            , ("REMOTE_ADDR", "192.168.1.115")
            , ("REMOTE_HOST", "ganjizza")
            , ("REQUEST_URI", "http://192.168.1.115:3000/")
            , ("REQUEST_METHOD", "POST")
            , ("HTTP_CONNECTION", "Keep-Alive")
            , ("HTTP_COOKIE", "_SESSION=fgUGM5J/k6mGAAW+MMXIJZCJHobw/oEbb6T17KQN0p9yNqiXn/m/ACrsnRjiCEgqtG4fogMUDI+jikoFGcwmPjvuD5d+MDz32iXvDdDJsFdsFMfivuey2H+n6IF6yFGD")
            , ("HTTP_USER_AGENT", "Dalvik/1.1.0 (Linux; U; Android 2.1-update1; sdk Build/ECLAIR)")
            , ("HTTP_HOST", "192.168.1.115:3000")
            , ("HTTP_ACCEPT", "*, */*")
            , ("HTTP_VERSION", "HTTP/1.1")
            , ("REQUEST_PATH", "/")
            ]
    let request' = defaultRequest
            { requestHeaders = headers
            }
    (params, files) <-
        case getRequestBodyType request' of
            Nothing -> return ([], [])
            Just rbt -> C.runResourceT $ sourceFile "test/requests/dalvik-request"
                       C.$$ sinkRequestBody lbsBackEnd rbt
    lookup "scannedTime" params @?= Just "1.298590056748E9"
    lookup "geoLong" params @?= Just "0"
    lookup "geoLat" params @?= Just "0"
    length files @?= 1

caseDebugRequestBody :: Assertion
caseDebugRequestBody = do
    flip runSession (debugApp postOutput) $ do
        let req = toRequest "application/x-www-form-urlencoded" "foo=bar&baz=bin"
        res <- srequest req
        assertStatus 200 res

    let qs = "?foo=bar&baz=bin"
    flip runSession (debugApp $ getOutput params) $ do
        assertStatus 200 =<< request defaultRequest
                { requestMethod = "GET"
                , queryString = map (\(k,v) -> (k, Just v)) params
                , rawQueryString = qs
                , requestHeaders = []
                , rawPathInfo = "/location"
                }
  where
    params = [("foo", "bar"), ("baz", "bin")]
    -- FIXME change back once we include post parameter output in logging postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)
    postOutput = T.pack $ "POST /\nAccept: \nStatus: 200 OK. /\n"
    getOutput params' = T.pack $ "GET /location\nAccept: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n"

    debugApp output' req = do
        iactual <- liftIO $ I.newIORef []
        middleware <- liftIO $ mkRequestLogger def
            { destination = Callback $ \strs -> I.modifyIORef iactual $ (++ strs)
            , outputFormat = Detailed False
            }
        res <- middleware (\_req -> return $ responseLBS status200 [ ] "") req
        actual <- liftIO $ I.readIORef iactual
        liftIO $ assertEqual "debug" output $ logsToBs actual
        return res
      where
        output = TE.encodeUtf8 $ T.toStrict output'
        logsToBs = S.concat . map logToBs

        logToBs (LB bs) = bs
        logToBs (LS s) = S8.pack s

    {-debugApp = debug $ \req -> do-}
        {-return $ responseLBS status200 [ ] ""-}