wai-extra 0.4.2 → 0.4.3
raw patch · 6 files changed
+475/−2 lines, 6 filesdep ~hspecbinary-addedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: hspec
API changes (from Hackage documentation)
Files
- runtests.hs +424/−0
- test/dalvik-request binary
- test/json +1/−0
- test/sample.hs +25/−0
- test/test.html +17/−0
- wai-extra.cabal +8/−2
+ runtests.hs view
@@ -0,0 +1,424 @@+{-# LANGUAGE OverloadedStrings #-}+import Test.Hspec+import Test.Hspec.HUnit ()+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 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.AcceptOverride+import Network.Wai.Middleware.Debug (debugHandle)+import Codec.Compression.GZip (decompress)++import Data.Enumerator (run_, enumList, ($$), Iteratee)+import Data.Enumerator.Binary (enumFile)+import Control.Monad.IO.Class (liftIO)+import Data.Maybe (fromMaybe)+import Network.HTTP.Types (parseSimpleQuery, status200)++main :: IO ()+main = hspecX $ do+ describe "Network.Wai.Parse"+ [ it "parseQueryString" caseParseQueryString+ , it "parseQueryString with question mark" caseParseQueryStringQM+ , it "parseHttpAccept" caseParseHttpAccept+ , it "parseRequestBody" caseParseRequestBody+ {-+ , 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 "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' :: Sink ([S8.ByteString] -> [S8.ByteString]) L.ByteString+ -> SRequest+ -> Iteratee S.ByteString IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)])+parseRequestBody' sink (SRequest req bod) =+ enumList 1 (L.toChunks bod) $$ parseRequestBody sink req++caseParseRequestBody :: Assertion+caseParseRequestBody = run_ 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' lbsSink $ 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' lbsSink $ 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' lbsSink $ 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' lbsSink $ toRequest' ctype2 content2+ liftIO $ assertEqual "parsing post multipart/form-data 2"+ expected2+ result2'++ result3' <- parseRequestBody' lbsSink $ toRequest' ctype3 content3+ liftIO $ assertEqual "parsing actual post multipart/form-data 2"+ expected3+ result3'++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 True $ const $ return $ responseLBS status200 [] "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++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) <- run_ $ enumFile "test/dalvik-request" $$ parseRequestBody lbsSink request'+ 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 qs) $ 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")]+ postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)+ getOutput _qs = T.pack $ "GET /location" ++ "\nAccept: \nGET " ++ (show params) -- \nAccept: \n" ++ (show params)++ debugApp output = debugHandle (\t -> liftIO $ assertEqual "debug" output t) $ \_req -> do+ return $ responseLBS status200 [ ] ""+ {-debugApp = debug $ \req -> do-}+ {-return $ responseLBS status200 [ ] ""-}
+ test/dalvik-request view
binary file changed (absent → 12166 bytes)
+ test/json view
@@ -0,0 +1,1 @@+{"data":"this is some data"}
+ test/sample.hs view
@@ -0,0 +1,25 @@+import Data.ByteString.Char8 (unpack, pack)+import Data.ByteString.Lazy (fromChunks)+import Network.Wai+import Network.Wai.Enumerator+import Network.Wai.Middleware.Gzip+import Network.Wai.Middleware.Jsonp+import Network.Wai.Middleware.CleanPath+import Network.Wai.Handler.SimpleServer++app :: [String] -> Application+app [] _ = return $ Response Status200 [] $ Right $ fromLBS+ $ fromChunks $ flip map [1..10000] $ \i -> pack $+ concat+ [ "<p>Just this same paragraph again. "+ , show i+ , "</p>"+ ]+app ["test.html"] _ = return $ Response Status200 [] $ Left "test.html"+app ["json"] _ =return $ Response Status200+ [(ContentType, pack "application/json")]+ $ Left "json"+app _ _ = return $ Response Status404 [] $ Left "../LICENSE"++main :: IO ()+main = run 3000 $ jsonp $ gzip $ cleanPath app
+ test/test.html view
@@ -0,0 +1,17 @@+<!DOCTYPE html>+<html>+ <head>+ <script src="http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.js"></script>+ <script>+ $(function(){+ $.getJSON("/json?callback=?", function(o){+ $("#dest").html(o.data);+ });+ });+ </script>+ </head>+ <body>+ There should be some content loaded below:+ <div id="dest"></div>+ </body>+</html>
wai-extra.cabal view
@@ -1,5 +1,5 @@ Name: wai-extra-Version: 0.4.2+Version: 0.4.3 Synopsis: Provides some basic WAI handlers and middleware. Description: The goal here is to provide common features without many dependencies. License: BSD3@@ -11,6 +11,12 @@ Build-Type: Simple Cabal-Version: >=1.8 Stability: Stable+extra-source-files:+ runtests.hs+ test/dalvik-request+ test/json+ test/test.html+ test/sample.hs Library Build-Depends: base >= 3 && < 5,@@ -51,7 +57,7 @@ build-depends: base >= 4 && < 5 , wai-extra , wai-test- , hspec >= 0.6.1 && < 0.7+ , hspec >= 0.8 && < 0.9 , HUnit , wai