git.iko.soy/typeable/wai
on master help sign in
Merge commit 'e03b7a3daf9e0903f6f6'

Conflicts: .gitignore

commit09149c2a054c6c47bbe712e05ac2d2e9c4e1a959 authorMichael Snoyman <michael@snoyman.com> dateSun 24 Jul 2011, 20:13 (15 years ago) parent5dd375fe03b7a3
4 files changed+61−19
compare with master
unifiedsplit
.gitignore+1 wai-extra/Network/Wai/Middleware/Debug.hs+27−7 wai-extra/Network/Wai/Parse.hs+2 wai-extra/runtests.hs+31−12
.gitignore+1
@@ -1,2 +1,3 @@
11dist/
22*.swp
3+cabal-dev
wai-extra/Network/Wai/Middleware/Debug.hs+27−7
@@ -4,9 +4,11 @@ module Network.Wai.Middleware.Debug
44 , debugDest
55 ) where
66
7−import Network.Wai (Middleware, requestMethod, requestHeaders, rawPathInfo, rawQueryString)
8−import Network.Wai.Parse (parseRequestBody, lbsSink, fileName)
7+import Network.Wai (Request(..), Middleware)
8+import Network.Wai.Parse (parseRequestBody, lbsSink, fileName, Param, File)
99import Data.ByteString.Char8 (unpack)
10+import qualified Data.ByteString as S
11+import qualified Data.ByteString.Lazy as L
1012import System.IO (hPutStrLn, stderr)
1113import Control.Monad.IO.Class (liftIO)
1214import qualified Data.Text.Lazy as T
@@ -18,19 +20,37 @@ debug :: Middleware
1820debug = debugDest $ hPutStrLn stderr . T.unpack
1921
2022-- | Prints a message using the given callback function for each request.
23+-- This is not for serious production use- it is inefficient.
24+-- It immediately consumes a POST body and fills it back in and is otherwise inefficient
2125debugDest :: (T.Text -> IO ()) -> Middleware
2226debugDest cb app req = do
2327 body <- consume
24− (params, files) <- liftIO $ run_ $ enumList 1 body $$ parseRequestBody lbsSink req
28+ postParams <- if any (requestMethod req ==) ["GET", "HEAD"]
29+ then return []
30+ else do postParams <- liftIO $ allPostParams req body
31+ return $ collectPostParams postParams
32+ let getParams = map emptyGetParam $ queryString req
33+
2534 liftIO $ cb $ T.pack $ concat
2635 [ unpack $ requestMethod req
2736 , " "
2837 , unpack $ rawPathInfo req
29− , unpack $ rawQueryString req
3038 , "\n"
3139 , (++) "Accept: " $ maybe "" unpack $ lookup "Accept" $ requestHeaders req
32− , "\n"
33− , if null params then "" else "Post parameters: " ++ show params ++ "\n"
34− , if null files then "" else "Post file names: " ++ show (map (fileName . snd) files) ++ "\n"
40+ , paramsToStr "GET " getParams
41+ , paramsToStr "POST " postParams
3542 ]
43+ -- we just consumed the body- fill the enumerator back up so it is available again
3644 liftIO $ run_ $ enumList 1 body $$ app req
45+ where
46+ paramsToStr prefix params = if null params then "" else "\n" ++ prefix ++ (show params)
47+
48+ allPostParams req body = run_ $ enumList 1 body $$ parseRequestBody lbsSink req
49+
50+ emptyGetParam :: (S.ByteString, Maybe S.ByteString) -> (S.ByteString, S.ByteString)
51+ emptyGetParam (k, Just v) = (k,v)
52+ emptyGetParam (k, Nothing) = (k,"")
53+
54+ collectPostParams :: ([Param], [File L.ByteString]) -> [Param]
55+ collectPostParams (postParams, files) = postParams ++
56+ (map (\(k,v) -> (k, S.append "FILE: " (fileName v))) files)
wai-extra/Network/Wai/Parse.hs+2
@@ -8,6 +8,8 @@ module Network.Wai.Parse
88 , Sink (..)
99 , lbsSink
1010 , tempFileSink
11+ , Param
12+ , File
1113 , FileInfo (..)
1214#if TEST
1315 , Bound (..)
wai-extra/runtests.hs+31−12
@@ -10,6 +10,7 @@ import qualified Data.ByteString as S
1010import qualified Data.ByteString.Char8 as S8
1111import qualified Data.ByteString.Lazy.Char8 as L8
1212import qualified Data.ByteString.Lazy as L
13+import qualified Data.Text.Lazy as T
1314import Control.Arrow
1415
1516import Network.Wai.Middleware.Jsonp
@@ -18,7 +19,7 @@ import Network.Wai.Middleware.Vhost
1819import Network.Wai.Middleware.Autohead
1920import Network.Wai.Middleware.MethodOverride
2021import Network.Wai.Middleware.AcceptOverride
21−import Network.Wai.Middleware.Debug (debug)
22+import Network.Wai.Middleware.Debug (debug, debugDest)
2223import Codec.Compression.GZip (decompress)
2324
2425import Data.Enumerator (run_, enumList, ($$), Iteratee)
@@ -36,11 +37,13 @@ testSuite = testGroup "Network.Wai.Parse"
3637 , testCase "parseQueryString with question mark" caseParseQueryStringQM
3738 , testCase "parseHttpAccept" caseParseHttpAccept
3839 , testCase "parseRequestBody" caseParseRequestBody
40+ {-
3941 , testCase "findBound" caseFindBound
4042 , testCase "sinkTillBound" caseSinkTillBound
4143 , testCase "killCR" caseKillCR
4244 , testCase "killCRLF" caseKillCRLF
4345 , testCase "takeLine" caseTakeLine
46+ -}
4447 , testCase "jsonp" caseJsonp
4548 , testCase "gzip" caseGzip
4649 , testCase "gzip not for MSIE" caseGzipMSIE
@@ -165,6 +168,7 @@ toRequest ctype content = SRequest (Request
165168 , requestMethod = "POST"
166169 , rawPathInfo = ""
167170 , rawQueryString = ""
171+ , queryString = []
168172 }) (L.fromChunks [content])
169173
170174toRequest' :: S8.ByteString -> S8.ByteString -> SRequest
@@ -172,6 +176,7 @@ toRequest' ctype content = SRequest (Request
172176 { requestHeaders = [("Content-Type", ctype)]
173177 }) (L.fromChunks $ map S.singleton $ S.unpack content)
174178
179+{-
175180caseFindBound :: Assertion
176181caseFindBound = do
177182 findBound (S8.pack "def") (S8.pack "abcdefghi") @?=
@@ -220,6 +225,7 @@ caseTakeLine = do
220225 helper haystack needle = do
221226 x <- run_ $ enumList 1 [haystack] $$ takeLine
222227 Just needle @=? x
228+-}
223229
224230jsonpApp = jsonp $ const $ return $ responseLBS
225231 status200
@@ -383,14 +389,27 @@ caseDalvikMultipart = do
383389 length files @?= 1
384390
385391caseDebugRequestBody :: Assertion
386−caseDebugRequestBody = flip runSession debugApp $ do
387− let req = toRequest "application/x-www-form-urlencoded" "foo=bar&baz=bin"
388− res <- srequest req
389− assertStatus 200 res
390− assertHeader "Parsed" (S8.pack $ show ([("foo", "bar"), ("baz", "bin")], [] :: [Int])) res
391−
392−debugApp = debug $ \req -> do
393− x <- parseRequestBody lbsSink req
394− return $ responseLBS status200
395− [ ("Parsed", S8.pack $ show x)
396− ] ""
392+caseDebugRequestBody = do
393+ flip runSession (debugApp postOutput) $ do
394+ let req = toRequest "application/x-www-form-urlencoded" "foo=bar&baz=bin"
395+ res <- srequest req
396+ assertStatus 200 res
397+
398+ let qs = "?foo=bar&baz=bin"
399+ flip runSession (debugApp $ getOutput qs) $ do
400+ assertStatus 200 =<< request Request
401+ { requestMethod = "GET"
402+ , queryString = map (\(k,v) -> (k, Just v)) params
403+ , rawQueryString = qs
404+ , requestHeaders = []
405+ , rawPathInfo = "/location"
406+ }
407+ where
408+ params = [("foo", "bar"), ("baz", "bin")]
409+ postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)
410+ getOutput qs = T.pack $ "GET /location" ++ "\nAccept: \nGET " ++ (show params) -- \nAccept: \n" ++ (show params)
411+
412+ debugApp output = debugDest (\t -> liftIO $ assertEqual "debug" output t) $ \req -> do
413+ return $ responseLBS status200 [ ] ""
414+ {-debugApp = debug $ \req -> do-}
415+ {-return $ responseLBS status200 [ ] ""-}