git.iko.soy/typeable/wai
on master help sign in
Better Debug and AcceptOverride, from Nubis
commit682389b01ea48730c60f7961648cefd5559584f2 authorMichael Snoyman <michael@snoyman.com> dateSat 5 Feb 2011, 23:47 (16 years ago) parentabf9643
4 files changed+60−2
compare with master
unifiedsplit
Network/Wai/Middleware/AcceptOverride.hs+26 Network/Wai/Middleware/Debug.hs+7−1 runtests.hs+25 wai-extra.cabal+2−1
Network/Wai/Middleware/AcceptOverride.hsnew file+26
@@ -0,0 +1,26 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Network.Wai.Middleware.AcceptOverride
4+ ( acceptOverride
5+ ) where
6+
7+import Network.Wai
8+import Network.Wai.Parse (parseQueryString)
9+import qualified Data.ByteString.Char8 as B8
10+
11+acceptOverride :: Middleware
12+acceptOverride app req =
13+ app req'
14+ where
15+ req' =
16+ case lookup "_accept" $ parseQueryString $ queryString req of
17+ Nothing -> req
18+ Just a -> req { requestHeaders = changeVal "Accept" (B8.unpack a) $ requestHeaders req}
19+
20+changeVal :: Eq a
21+ => a
22+ -> String
23+ -> [(a, B8.ByteString)]
24+ -> [(a, B8.ByteString)]
25+changeVal key val old = (key, B8.pack val)
26+ : filter (\(k, _) -> k /= key) old
Network/Wai/Middleware/Debug.hs+7−1
@@ -1,9 +1,11 @@
1+{-# LANGUAGE OverloadedStrings #-}
12module Network.Wai.Middleware.Debug (debug) where
23
3−import Network.Wai (Middleware, requestMethod, pathInfo)
4+import Network.Wai (Middleware, requestMethod, requestHeaders, pathInfo, queryString)
45import Data.ByteString.Char8 (unpack)
56import System.IO (hPutStrLn, stderr)
67import Control.Monad.IO.Class (liftIO)
8+import Data.Maybe
79
810-- | Prints a message to 'stderr' for each request.
911debug :: Middleware
@@ -12,5 +14,9 @@ debug app req = do
1214 [ unpack $ requestMethod req
1315 , " "
1416 , unpack $ pathInfo req
17+ , unpack $ queryString req
18+ , "\n"
19+ , (++) "Accept: " $ unpack $ fromMaybe "" $ lookup "Accept" $ requestHeaders req
20+ , "\n"
1521 ]
1622 app req
runtests.hs+25
@@ -17,10 +17,12 @@ import Network.Wai.Middleware.Gzip
1717import Network.Wai.Middleware.Vhost
1818import Network.Wai.Middleware.Autohead
1919import Network.Wai.Middleware.MethodOverride
20+import Network.Wai.Middleware.AcceptOverride
2021import Codec.Compression.GZip (decompress)
2122
2223import Data.Enumerator (run_, enumList, ($$), Iteratee)
2324import Control.Monad.IO.Class (liftIO)
25+import Data.Maybe (fromMaybe)
2426
2527main :: IO ()
2628main = defaultMain [testSuite]
@@ -41,6 +43,7 @@ testSuite = testGroup "Network.Wai.Parse"
4143 , testCase "vhost" caseVhost
4244 , testCase "autohead" caseAutohead
4345 , testCase "method override" caseMethodOverride
46+ , testCase "accept override" caseAcceptOverride
4447 ]
4548
4649caseParseQueryString :: Assertion
@@ -309,3 +312,25 @@ caseMethodOverride = flip runSession moApp $ do
309312 , queryString = "_method=PUT"
310313 }
311314 assertHeader "Method" "PUT" sres3
315+
316+aoApp = acceptOverride $ \req -> return $ responseLBS status200
317+ [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""
318+
319+caseAcceptOverride = flip runSession aoApp $ do
320+ sres1 <- request Request
321+ { queryString = ""
322+ , requestHeaders = [("Accept", "foo")]
323+ }
324+ assertHeader "Accept" "foo" sres1
325+
326+ sres2 <- request Request
327+ { queryString = ""
328+ , requestHeaders = [("Accept", "bar")]
329+ }
330+ assertHeader "Accept" "bar" sres2
331+
332+ sres3 <- request Request
333+ { queryString = "_accept=baz"
334+ , requestHeaders = [("Accept", "bar")]
335+ }
336+ assertHeader "Accept" "baz" sres3
wai-extra.cabal+2−1
@@ -1,5 +1,5 @@
11Name: wai-extra
2−Version: 0.3.1
2+Version: 0.3.2
33Synopsis: Provides some basic WAI handlers and middleware.
44Description: The goal here is to provide common features without many dependencies.
55License: BSD3
@@ -26,6 +26,7 @@ Library
2626 enumerator >= 0.4 && < 0.5,
2727 blaze-builder >= 0.2.1.3 && < 0.3
2828 Exposed-modules: Network.Wai.Handler.CGI
29+ Network.Wai.Middleware.AcceptOverride
2930 Network.Wai.Middleware.Autohead
3031 Network.Wai.Middleware.CleanPath
3132 Network.Wai.Middleware.Debug