git.iko.soy/typeable/wai
on master help sign in
Add 'wai-extra/' from commit '29076d018b0cc159c3ccf3050350e4b7469f2c6c'

git-subtree-dir: wai-extra git-subtree-mainline: ebedc4d08313552a85108039c0f29ad5975dc5e2 git-subtree-split: 29076d018b0cc159c3ccf3050350e4b7469f2c6c

commit6ab2dfe739f7e0404340963e9a75e015263bee71 authorMichael Snoyman <michael@snoyman.com> dateFri 22 Jul 2011, 16:51 (15 years ago) parentebedc4d29076d0
23 files changed+1456
compare with master
unifiedsplit
wai-extra/.gitignore+2 wai-extra/LICENSE+25 wai-extra/Network/Wai/Handler/CGI.hs+178 wai-extra/Network/Wai/Middleware/AcceptOverride.hs+26 wai-extra/Network/Wai/Middleware/Autohead.hs+23 wai-extra/Network/Wai/Middleware/CleanPath.hs+30 wai-extra/Network/Wai/Middleware/Debug.hs+36 wai-extra/Network/Wai/Middleware/Gzip.hs+70 wai-extra/Network/Wai/Middleware/Jsonp.hs+106 wai-extra/Network/Wai/Middleware/MethodOverride.hs+16 wai-extra/Network/Wai/Middleware/Rewrite.hs+33 wai-extra/Network/Wai/Middleware/Vhost.hs+9 wai-extra/Network/Wai/Parse.hs+342 wai-extra/Network/Wai/Zlib.hs+41 wai-extra/README+1 wai-extra/Setup.lhs+7 wai-extra/proxy.hs+25 wai-extra/runtests.hs+396 wai-extra/test/dalvik-request wai-extra/test/json+1 wai-extra/test/sample.hs+25 wai-extra/test/test.html+17 wai-extra/wai-extra.cabal+47
wai-extra/.gitignorenew file+2
@@ -0,0 +1,2 @@
1+*.swp
2+dist
wai-extra/LICENSEnew file+25
@@ -0,0 +1,25 @@
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
3+
4+Copyright 2010, Michael Snoyman. All rights reserved.
5+
6+Redistribution and use in source and binary forms, with or without
7+modification, are permitted provided that the following conditions are met:
8+
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
wai-extra/Network/Wai/Handler/CGI.hsnew file+178
@@ -0,0 +1,178 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RankNTypes #-}
3+-- | Backend for Common Gateway Interface. Almost all users should use the
4+-- 'run' function.
5+module Network.Wai.Handler.CGI
6+ ( run
7+ , runSendfile
8+ , runGeneric
9+ , requestBodyFunc
10+ ) where
11+
12+import Network.Wai
13+import Network.Socket (getAddrInfo, addrAddress)
14+import System.Environment (getEnvironment)
15+import Data.Maybe (fromMaybe)
16+import qualified Data.ByteString.Char8 as B
17+import qualified Data.ByteString.Lazy as L
18+import Control.Arrow ((***))
19+import Data.Char (toLower)
20+import qualified System.IO
21+import qualified Data.String as String
22+import Data.Enumerator
23+ ( Enumerator, Step (..), Stream (..), continue, yield
24+ , enumList, ($$), joinI, returnI, (>>==), run_
25+ )
26+import Data.Monoid (mconcat)
27+import Blaze.ByteString.Builder (fromByteString, toLazyByteString)
28+import Blaze.ByteString.Builder.Char8 (fromChar, fromString)
29+import Blaze.ByteString.Builder.Enumerator (builderToByteString)
30+import Control.Monad.IO.Class (liftIO)
31+import Data.ByteString.Lazy.Internal (defaultChunkSize)
32+import System.IO (Handle)
33+import Network.HTTP.Types (Status (..))
34+import qualified Network.HTTP.Types as H
35+import qualified Data.CaseInsensitive as CI
36+
37+safeRead :: Read a => a -> String -> a
38+safeRead d s =
39+ case reads s of
40+ ((x, _):_) -> x
41+ [] -> d
42+
43+lookup' :: String -> [(String, String)] -> String
44+lookup' key pairs = fromMaybe "" $ lookup key pairs
45+
46+-- | Run an application using CGI.
47+run :: Application -> IO ()
48+run app = do
49+ vars <- getEnvironment
50+ let input = requestBodyHandle System.IO.stdin
51+ output = B.hPut System.IO.stdout
52+ runGeneric vars input output Nothing app
53+
54+-- | Some web servers provide an optimization for sending files via a sendfile
55+-- system call via a special header. To use this feature, provide that header
56+-- name here.
57+runSendfile :: B.ByteString -- ^ sendfile header
58+ -> Application -> IO ()
59+runSendfile sf app = do
60+ vars <- getEnvironment
61+ let input = requestBodyHandle System.IO.stdin
62+ output = B.hPut System.IO.stdout
63+ runGeneric vars input output (Just sf) app
64+
65+-- | A generic CGI helper, which allows other backends (FastCGI and SCGI) to
66+-- use the same code as CGI. Most users will not need this function, and can
67+-- stick with 'run' or 'runSendfile'.
68+runGeneric
69+ :: [(String, String)] -- ^ all variables
70+ -> (forall a. Int -> Enumerator B.ByteString IO a) -- ^ responseBody of input
71+ -> (B.ByteString -> IO ()) -- ^ destination for output
72+ -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?
73+ -> Application
74+ -> IO ()
75+runGeneric vars inputH outputH xsendfile app = do
76+ let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars
77+ pinfo = lookup' "PATH_INFO" vars
78+ qstring = lookup' "QUERY_STRING" vars
79+ servername = lookup' "SERVER_NAME" vars
80+ serverport = safeRead 80 $ lookup' "SERVER_PORT" vars
81+ contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars
82+ remoteHost' =
83+ case lookup "REMOTE_ADDR" vars of
84+ Just x -> x
85+ Nothing ->
86+ case lookup "REMOTE_HOST" vars of
87+ Just x -> x
88+ Nothing -> ""
89+ isSecure' =
90+ case map toLower $ lookup' "SERVER_PROTOCOL" vars of
91+ "https" -> True
92+ _ -> False
93+ addrs <- getAddrInfo Nothing (Just remoteHost') Nothing
94+ let addr =
95+ case addrs of
96+ a:_ -> addrAddress a
97+ [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'
98+ let env = Request
99+ { requestMethod = rmethod
100+ , rawPathInfo = B.pack pinfo
101+ , pathInfo = H.decodePathSegments $ B.pack pinfo
102+ , rawQueryString = B.pack qstring
103+ , queryString = H.parseQuery $ B.pack qstring
104+ , serverName = B.pack servername
105+ , serverPort = serverport
106+ , requestHeaders = map (cleanupVarName *** B.pack) vars
107+ , isSecure = isSecure'
108+ , remoteHost = addr
109+ , httpVersion = H.http11 -- FIXME
110+ }
111+ -- FIXME worry about exception?
112+ res <- run_ $ inputH contentLength $$ app env
113+ case (xsendfile, res) of
114+ (Just sf, ResponseFile s hs fp Nothing) ->
115+ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp
116+ _ -> responseEnumerator res $ \s hs ->
117+ joinI $ enumList 1 [headers s hs, fromChar '\n'] $$ builderIter
118+ where
119+ headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))
120+ status (Status i m) = (fromByteString "Status", mconcat
121+ [ fromString $ show i
122+ , fromChar ' '
123+ , fromByteString m
124+ ])
125+ header' (x, y) = (fromByteString $ CI.original x, fromByteString y)
126+ header (x, y) = mconcat
127+ [ x
128+ , fromByteString ": "
129+ , y
130+ , fromChar '\n'
131+ ]
132+ sfBuilder s hs sf fp = mconcat
133+ [ headers s hs
134+ , header $ (fromByteString sf, fromString fp)
135+ , fromChar '\n'
136+ , fromByteString sf
137+ , fromByteString " not supported"
138+ ]
139+ bsStep = Continue bsStep'
140+ bsStep' EOF = yield () EOF
141+ bsStep' (Chunks []) = continue bsStep'
142+ bsStep' (Chunks bss) = liftIO (mapM_ outputH bss) >> continue bsStep'
143+ builderIter = builderToByteString bsStep
144+ fixHeaders h =
145+ case lookup "content-type" h of
146+ Nothing -> ("Content-Type", "text/html; charset=utf-8") : h
147+ Just _ -> h
148+
149+cleanupVarName :: String -> CI.CI B.ByteString
150+cleanupVarName ('H':'T':'T':'P':'_':a:as) =
151+ String.fromString $ a : helper' as
152+ where
153+ helper' ('_':x:rest) = '-' : x : helper' rest
154+ helper' (x:rest) = toLower x : helper' rest
155+ helper' [] = []
156+cleanupVarName "CONTENT_TYPE" = "Content-Type"
157+cleanupVarName "CONTENT_LENGTH" = "Content-Length"
158+cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"
159+cleanupVarName x = String.fromString x -- FIXME remove?
160+
161+requestBodyHandle :: Handle -> Int -> Enumerator B.ByteString IO a
162+requestBodyHandle h =
163+ requestBodyFunc go
164+ where
165+ go i = Just `fmap` B.hGet h (min i defaultChunkSize)
166+
167+requestBodyFunc :: (Int -> IO (Maybe B.ByteString))
168+ -> Int
169+ -> Enumerator B.ByteString IO a
170+requestBodyFunc _ 0 step = returnI step
171+requestBodyFunc h len (Continue k) = do
172+ mbs <- liftIO $ h len
173+ case mbs of
174+ Nothing -> continue k
175+ Just bs -> do
176+ let newLen = len - B.length bs
177+ k (Chunks [bs]) >>== requestBodyFunc h newLen
178+requestBodyFunc _ _ step = returnI step
wai-extra/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 Control.Monad (join)
9+import Data.ByteString (ByteString)
10+
11+acceptOverride :: Middleware
12+acceptOverride app req =
13+ app req'
14+ where
15+ req' =
16+ case join $ lookup "_accept" $ queryString req of
17+ Nothing -> req
18+ Just a -> req { requestHeaders = changeVal "Accept" a $ requestHeaders req}
19+
20+changeVal :: Eq a
21+ => a
22+ -> ByteString
23+ -> [(a, ByteString)]
24+ -> [(a, ByteString)]
25+changeVal key val old = (key, val)
26+ : filter (\(k, _) -> k /= key) old
wai-extra/Network/Wai/Middleware/Autohead.hsnew file+23
@@ -0,0 +1,23 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+-- | Automatically produce responses to HEAD requests based on the underlying
3+-- applications GET response.
4+module Network.Wai.Middleware.Autohead (autohead) where
5+
6+import Network.Wai
7+import Data.Monoid (mempty)
8+import Data.Enumerator (enumEOF, ($$))
9+
10+autohead :: Middleware
11+autohead app req
12+ | requestMethod req == "HEAD" = do
13+ res <- app req { requestMethod = "GET" }
14+ case res of
15+ ResponseFile s hs _ _ -> return $ ResponseBuilder s hs mempty
16+ ResponseBuilder s hs _ -> return $ ResponseBuilder s hs mempty
17+ ResponseEnumerator e -> do
18+ let helper f =
19+ let helper' s hs = enumEOF $$ f s hs
20+ in e helper'
21+ return $ ResponseEnumerator helper
22+ | otherwise = app req
23+
wai-extra/Network/Wai/Middleware/CleanPath.hsnew file+30
@@ -0,0 +1,30 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Network.Wai.Middleware.CleanPath
3+ ( cleanPath
4+ ) where
5+
6+import Network.Wai
7+import qualified Data.ByteString.Char8 as B
8+import qualified Data.ByteString.Lazy as L
9+import Network.HTTP.Types (status301)
10+import Data.Text (Text)
11+import Data.Monoid (mconcat)
12+
13+cleanPath :: ([Text] -> Either B.ByteString [Text])
14+ -> B.ByteString
15+ -> ([Text] -> Application)
16+ -> Application
17+cleanPath splitter prefix app env =
18+ case splitter $ pathInfo env of
19+ Right pieces -> app pieces env
20+ Left p -> return
21+ $ responseLBS status301
22+ [("Location", mconcat [prefix, p, suffix])]
23+ $ L.empty
24+ where
25+ -- include the query string if present
26+ suffix =
27+ case B.uncons $ rawQueryString env of
28+ Nothing -> B.empty
29+ Just ('?', _) -> rawQueryString env
30+ _ -> B.cons '?' $ rawQueryString env
wai-extra/Network/Wai/Middleware/Debug.hsnew file+36
@@ -0,0 +1,36 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Network.Wai.Middleware.Debug
3+ ( debug
4+ , debugDest
5+ ) where
6+
7+import Network.Wai (Middleware, requestMethod, requestHeaders, rawPathInfo, rawQueryString)
8+import Network.Wai.Parse (parseRequestBody, lbsSink, fileName)
9+import Data.ByteString.Char8 (unpack)
10+import System.IO (hPutStrLn, stderr)
11+import Control.Monad.IO.Class (liftIO)
12+import qualified Data.Text.Lazy as T
13+import Data.Enumerator (run_, ($$), enumList)
14+import Data.Enumerator.List (consume)
15+
16+-- | Prints a message to 'stderr' for each request.
17+debug :: Middleware
18+debug = debugDest $ hPutStrLn stderr . T.unpack
19+
20+-- | Prints a message using the given callback function for each request.
21+debugDest :: (T.Text -> IO ()) -> Middleware
22+debugDest cb app req = do
23+ body <- consume
24+ (params, files) <- liftIO $ run_ $ enumList 1 body $$ parseRequestBody lbsSink req
25+ liftIO $ cb $ T.pack $ concat
26+ [ unpack $ requestMethod req
27+ , " "
28+ , unpack $ rawPathInfo req
29+ , unpack $ rawQueryString req
30+ , "\n"
31+ , (++) "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"
35+ ]
36+ liftIO $ run_ $ enumList 1 body $$ app req
wai-extra/Network/Wai/Middleware/Gzip.hsnew file+70
@@ -0,0 +1,70 @@
1+{-# LANGUAGE Rank2Types #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+---------------------------------------------------------
5+-- |
6+-- Module : Network.Wai.Middleware.Gzip
7+-- Copyright : Michael Snoyman
8+-- License : BSD3
9+--
10+-- Maintainer : Michael Snoyman <michael@snoyman.com>
11+-- Stability : Unstable
12+-- Portability : portable
13+--
14+-- Automatic gzip compression of responses.
15+--
16+---------------------------------------------------------
17+module Network.Wai.Middleware.Gzip (gzip) where
18+
19+import Network.Wai
20+import Network.Wai.Zlib
21+import Data.Maybe (fromMaybe)
22+import Data.Enumerator (($$), joinI)
23+import qualified Data.ByteString.Char8 as S8
24+import qualified Data.ByteString as S
25+
26+-- | Use gzip to compress the body of the response.
27+--
28+-- Analyzes the \"Accept-Encoding\" header from the client to determine
29+-- if gzip is supported.
30+--
31+-- Possible future enhancements:
32+--
33+-- * Only compress if the response is above a certain size.
34+--
35+-- * I've read that IE can\'t support compression for Javascript files.
36+gzip :: Bool -- ^ should we gzip files?
37+ -> Middleware
38+gzip files app env = do
39+ res <- app env
40+ return $
41+ case res of
42+ ResponseFile{} | not files -> res
43+ _ -> if "gzip" `elem` enc && not isMSIE6
44+ then ResponseEnumerator $ compressE $ responseEnumerator res
45+ else res
46+ where
47+ enc = fromMaybe [] $ (splitCommas . S8.unpack)
48+ `fmap` lookup "Accept-Encoding" (requestHeaders env)
49+ ua = fromMaybe "" $ lookup "user-agent" $ requestHeaders env
50+ isMSIE6 = "MSIE 6" `S.isInfixOf` ua
51+
52+compressE :: (forall a. ResponseEnumerator a)
53+ -> (forall a. ResponseEnumerator a)
54+compressE re f =
55+ re f'
56+ --e s hs'
57+ where
58+ f' s hs =
59+ joinI $ compress $$ f s hs'
60+ where
61+ -- Remove Content-Length header, since we will certainly have a
62+ -- different length after gzip compression.
63+ hs' = ("Content-Encoding", "gzip") : filter notLength hs
64+ notLength (x, _) = x /= "content-length"
65+
66+splitCommas :: String -> [String]
67+splitCommas [] = []
68+splitCommas x =
69+ let (y, z) = break (== ',') x
70+ in y : splitCommas (dropWhile (== ' ') $ drop 1 z)
wai-extra/Network/Wai/Middleware/Jsonp.hsnew file+106
@@ -0,0 +1,106 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RankNTypes #-}
3+---------------------------------------------------------
4+-- |
5+-- Module : Network.Wai.Middleware.Jsonp
6+-- Copyright : Michael Snoyman
7+-- License : BSD3
8+--
9+-- Maintainer : Michael Snoyman <michael@snoyman.com>
10+-- Stability : Unstable
11+-- Portability : portable
12+--
13+-- Automatic wrapping of JSON responses to convert into JSONP.
14+--
15+---------------------------------------------------------
16+module Network.Wai.Middleware.Jsonp (jsonp) where
17+
18+import Network.Wai
19+import Data.ByteString (ByteString)
20+import qualified Data.ByteString.Char8 as B8
21+import Data.Enumerator (($$), enumList, Step (..), Enumerator, Iteratee, Enumeratee, joinI, checkDone, continue, Stream (..), (>>==))
22+import Blaze.ByteString.Builder (copyByteString, Builder)
23+import Blaze.ByteString.Builder.Char8 (fromChar)
24+import Data.Monoid (mappend)
25+import Control.Monad (join)
26+import Data.Maybe (fromMaybe)
27+import qualified Data.ByteString as S
28+
29+-- | Wrap json responses in a jsonp callback.
30+--
31+-- Basically, if the user requested a \"text\/javascript\" and supplied a
32+-- \"callback\" GET parameter, ask the application for an
33+-- \"application/json\" response, then convern that into a JSONP response,
34+-- having a content type of \"text\/javascript\" and calling the specified
35+-- callback function.
36+jsonp :: Middleware
37+jsonp app env = do
38+ let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env
39+ let callback :: Maybe B8.ByteString
40+ callback =
41+ if B8.pack "text/javascript" `B8.isInfixOf` accept
42+ then join $ lookup "callback" $ queryString env
43+ else Nothing
44+ let env' =
45+ case callback of
46+ Nothing -> env
47+ Just _ -> env
48+ { requestHeaders = changeVal "Accept"
49+ "application/json"
50+ $ requestHeaders env
51+ }
52+ res <- app env'
53+ case callback of
54+ Nothing -> return res
55+ Just c -> go c res
56+ where
57+ go c r@(ResponseFile _ hs _ _) = go' c r hs
58+ go c r@(ResponseBuilder s hs b) =
59+ case checkJSON hs of
60+ Nothing -> return r
61+ Just hs' -> return $ ResponseBuilder s hs' $
62+ copyByteString c
63+ `mappend` fromChar '('
64+ `mappend` b
65+ `mappend` fromChar ')'
66+ go c (ResponseEnumerator e) = addCallback c e
67+ go' c r hs =
68+ case checkJSON hs of
69+ Just _ -> addCallback c $ responseEnumerator r
70+ Nothing -> return r
71+ checkJSON hs =
72+ case lookup "Content-Type" hs of
73+ Just x
74+ | B8.pack "application/json" `S.isPrefixOf` x -> Just $ fixHeaders hs
75+ _ -> Nothing
76+ fixHeaders = changeVal "Content-Type" "text/javascript"
77+ addCallback :: B8.ByteString -> (forall a. ResponseEnumerator a)
78+ -> Iteratee B8.ByteString IO Response
79+ addCallback cb e =
80+ return $ ResponseEnumerator $ helper
81+ where
82+ helper f =
83+ e helper'
84+ where
85+ helper' s hs =
86+ case checkJSON hs of
87+ Just hs' -> wrap $$ f s hs'
88+ Nothing -> f s hs
89+ wrap :: Step Builder IO b -> Iteratee Builder IO b
90+ wrap step = joinI $ after (enumList 1 [fromChar ')'])
91+ $$ enumList 1 [copyByteString cb, fromChar '('] step
92+ after :: Enumerator Builder IO b -> Enumeratee Builder Builder IO b
93+ after enum =
94+ loop
95+ where
96+ loop = checkDone $ continue . step
97+ step k EOF = enum (Continue k) >>== return
98+ step k s = k s >>== loop
99+
100+changeVal :: Eq a
101+ => a
102+ -> ByteString
103+ -> [(a, ByteString)]
104+ -> [(a, ByteString)]
105+changeVal key val old = (key, val)
106+ : filter (\(k, _) -> k /= key) old
wai-extra/Network/Wai/Middleware/MethodOverride.hsnew file+16
@@ -0,0 +1,16 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Network.Wai.Middleware.MethodOverride
3+ ( methodOverride
4+ ) where
5+
6+import Network.Wai
7+import Control.Monad (join)
8+
9+methodOverride :: Middleware
10+methodOverride app req =
11+ app req'
12+ where
13+ req' =
14+ case join $ lookup "_method" $ queryString req of
15+ Nothing -> req
16+ Just m -> req { requestMethod = m }
wai-extra/Network/Wai/Middleware/Rewrite.hsnew file+33
@@ -0,0 +1,33 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Network.Wai.Middleware.Rewrite
3+ ( rewrite, autoHtmlRewrite
4+ ) where
5+
6+import Network.Wai
7+import System.Directory (doesFileExist)
8+import Control.Monad.IO.Class (liftIO)
9+import Data.Text (Text, unpack, pack)
10+
11+-- | rewrite based on your own conversion rules
12+-- Example usage: rewrite (autoHtmlRewrite "static")
13+rewrite :: ([Text] -> IO [Text]) -> Middleware
14+rewrite convert app req = do
15+ newPathInfo <- liftIO $ convert $ pathInfo req
16+ app req { pathInfo = newPathInfo }
17+
18+-- | example rewriter
19+-- implements 2 rules for static html re-writes
20+-- 1) for a directory foo/, check for foo/index.html
21+-- 2) for a non-directory bar, check for bar.html
22+-- if the file exists, do the rewrite
23+autoHtmlRewrite :: String -> [Text] -> IO [Text]
24+autoHtmlRewrite staticDir pieces' = do
25+ fe <- doesFileExist $ staticDir ++ "/" ++ reWritePath
26+ return $ if fe then map pack reWritePieces else pieces'
27+ where
28+ pieces = map unpack pieces'
29+ reWritePath = concat $ map ((:) '/') reWritePieces
30+ reWritePieces =
31+ if (null pieces) || (null $ last pieces)
32+ then pieces ++ ["index.html"]
33+ else (init pieces) ++ [(last pieces) ++ ".html"]
wai-extra/Network/Wai/Middleware/Vhost.hsnew file+9
@@ -0,0 +1,9 @@
1+module Network.Wai.Middleware.Vhost (vhost) where
2+
3+import Network.Wai
4+
5+vhost :: [(Request -> Bool, Application)] -> Application -> Application
6+vhost vhosts def req =
7+ case filter (\(b, _) -> b req) vhosts of
8+ [] -> def req
9+ (_, app):_ -> app req
wai-extra/Network/Wai/Parse.hsnew file+342
@@ -0,0 +1,342 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+-- | Some helpers for parsing data out of a raw WAI 'Request'.
4+
5+module Network.Wai.Parse
6+ ( parseHttpAccept
7+ , parseRequestBody
8+ , Sink (..)
9+ , lbsSink
10+ , tempFileSink
11+ , FileInfo (..)
12+#if TEST
13+ , Bound (..)
14+ , findBound
15+ , sinkTillBound
16+ , killCR
17+ , killCRLF
18+ , takeLine
19+#endif
20+ ) where
21+
22+import qualified Data.ByteString as S
23+import qualified Data.ByteString.Lazy as L
24+import qualified Data.ByteString.Char8 as S8
25+import Data.Word (Word8)
26+import Data.Bits
27+import Data.Maybe (fromMaybe)
28+import Data.List (sortBy)
29+import Data.Function (on)
30+import System.Directory (removeFile, getTemporaryDirectory)
31+import System.IO (hClose, openBinaryTempFile, Handle)
32+import Network.Wai
33+import Data.Enumerator (Iteratee, yield)
34+import qualified Data.Enumerator as E
35+import qualified Data.Enumerator.List as EL
36+import Control.Monad.IO.Class (liftIO)
37+import qualified Network.HTTP.Types as H
38+
39+uncons :: S.ByteString -> Maybe (Word8, S.ByteString)
40+uncons s
41+ | S.null s = Nothing
42+ | otherwise = Just (S.head s, S.tail s)
43+
44+breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
45+breakDiscard w s =
46+ let (x, y) = S.break (== w) s
47+ in (x, S.drop 1 y)
48+
49+qsDecode :: S.ByteString -> S.ByteString
50+qsDecode z = fst $ S.unfoldrN (S.length z) go z
51+ where
52+ go bs =
53+ case uncons bs of
54+ Nothing -> Nothing
55+ Just (43, ws) -> Just (32, ws) -- plus to space
56+ Just (37, ws) -> Just $ fromMaybe (37, ws) $ do -- percent
57+ (x, xs) <- uncons ws
58+ x' <- hexVal x
59+ (y, ys) <- uncons xs
60+ y' <- hexVal y
61+ Just $ (combine x' y', ys)
62+ Just (w, ws) -> Just (w, ws)
63+ hexVal w
64+ | 48 <= w && w <= 57 = Just $ w - 48 -- 0 - 9
65+ | 65 <= w && w <= 70 = Just $ w - 55 -- A - F
66+ | 97 <= w && w <= 102 = Just $ w - 87 -- a - f
67+ | otherwise = Nothing
68+ combine :: Word8 -> Word8 -> Word8
69+ combine a b = shiftL a 4 .|. b
70+
71+-- | Parse the HTTP accept string to determine supported content types.
72+parseHttpAccept :: S.ByteString -> [S.ByteString]
73+parseHttpAccept = map fst
74+ . sortBy (rcompare `on` snd)
75+ . map grabQ
76+ . S.split 44 -- comma
77+ where
78+ rcompare :: Double -> Double -> Ordering
79+ rcompare = flip compare
80+ grabQ s =
81+ let (s', q) = breakDiscard 59 s -- semicolon
82+ (_, q') = breakDiscard 61 q -- equals sign
83+ in (trimWhite s', readQ $ trimWhite q')
84+ readQ s = case reads $ S8.unpack s of
85+ (x, _):_ -> x
86+ _ -> 1.0
87+ trimWhite = S.dropWhile (== 32) -- space
88+
89+-- | A destination for data, the opposite of a 'Source'.
90+data Sink x y = Sink
91+ { sinkInit :: IO x
92+ , sinkAppend :: x -> S.ByteString -> IO x
93+ , sinkClose :: x -> IO y
94+ , sinkFinalize :: y -> IO ()
95+ }
96+
97+lbsSink :: Sink ([S.ByteString] -> [S.ByteString]) L.ByteString
98+lbsSink = Sink
99+ { sinkInit = return id
100+ , sinkAppend = \front bs -> return $ front . (:) bs
101+ , sinkClose = \front -> return $ L.fromChunks $ front []
102+ , sinkFinalize = \_ -> return ()
103+ }
104+
105+tempFileSink :: Sink (FilePath, Handle) FilePath
106+tempFileSink = Sink
107+ { sinkInit = do
108+ tempDir <- getTemporaryDirectory
109+ openBinaryTempFile tempDir "webenc.buf"
110+ , sinkAppend = \(fp, h) bs -> S.hPut h bs >> return (fp, h)
111+ , sinkClose = \(fp, h) -> do
112+ hClose h
113+ return fp
114+ , sinkFinalize = \fp -> removeFile fp
115+ }
116+
117+-- | Information on an uploaded file.
118+data FileInfo c = FileInfo
119+ { fileName :: S.ByteString
120+ , fileContentType :: S.ByteString
121+ , fileContent :: c
122+ }
123+ deriving (Eq, Show)
124+
125+type Param = (S.ByteString, S.ByteString)
126+type File y = (S.ByteString, FileInfo y)
127+
128+parseRequestBody :: Sink x y
129+ -> Request
130+ -> Iteratee S.ByteString IO ([Param], [File y])
131+parseRequestBody sink req = do
132+ case ctype of
133+ Nothing -> return ([], [])
134+ Just Nothing -> do -- url-encoded
135+ -- NOTE: in general, url-encoded data will be in a single chunk.
136+ -- Therefore, I'm optimizing for the usual case by sticking with
137+ -- strict byte strings here.
138+ bs <- EL.consume
139+ return (H.parseSimpleQuery $ S.concat bs, [])
140+ Just (Just bound) -> -- multi-part
141+ let bound'' = S8.pack "--" `S.append` bound
142+ in parsePieces sink bound''
143+ where
144+ urlenc = S8.pack "application/x-www-form-urlencoded"
145+ formBound = S8.pack "multipart/form-data;"
146+ bound' = "boundary="
147+ boundary s =
148+ if "multipart/form-data;" `S.isPrefixOf` s
149+ then
150+ let s' = S.dropWhile (== 32) $ S.drop (S.length formBound) s
151+ in if bound' `S.isPrefixOf` s'
152+ then Just $ S.drop (S.length bound') s'
153+ else Nothing
154+ else Nothing
155+ ctype = do
156+ ctype' <- lookup "Content-Type" $ requestHeaders req
157+ if urlenc `S.isPrefixOf` ctype'
158+ then Just Nothing
159+ else case boundary ctype' of
160+ Just x -> Just $ Just x
161+ Nothing -> Nothing
162+
163+takeLine :: Iteratee S.ByteString IO (Maybe S.ByteString)
164+takeLine = do
165+ mbs <- EL.head
166+ case mbs of
167+ Nothing -> return Nothing
168+ Just bs ->
169+ let (x, y) = S.break (== 10) bs -- LF
170+ in if S.null y
171+ then do
172+ x' <- takeLine
173+ case x' of
174+ Nothing -> return $ Just $ killCR x
175+ Just x'' -> return $ Just $ killCR $ S.append x x''
176+ else do
177+ E.yield () $ E.Chunks [S.drop 1 y]
178+ return $ Just $ killCR x
179+
180+takeLines :: Iteratee S.ByteString IO [S.ByteString]
181+takeLines = do
182+ res <- takeLine
183+ case res of
184+ Nothing -> return []
185+ Just l
186+ | S.null l -> return []
187+ | otherwise -> do
188+ ls <- takeLines
189+ return $ l : ls
190+
191+parsePieces :: Sink x y -> S.ByteString
192+ -> Iteratee S.ByteString IO ([Param], [File y])
193+parsePieces sink bound = do
194+ _boundLine <- takeLine
195+ res' <- takeLines
196+ case res' of
197+ [] -> return ([], [])
198+ _ -> do
199+ let ls' = map parsePair res'
200+ let x = do
201+ cd <- lookup contDisp ls'
202+ let ct = lookup contType ls'
203+ let attrs = parseAttrs cd
204+ name <- lookup "name" attrs
205+ return (ct, name, lookup "filename" attrs)
206+ case x of
207+ Just (mct, name, Just filename) -> do
208+ let ct = fromMaybe "application/octet-stream" mct
209+ seed <- liftIO $ sinkInit sink
210+ (seed', wasFound) <-
211+ sinkTillBound bound (sinkAppend sink) seed
212+ y <- liftIO $ sinkClose sink seed'
213+ let fi = FileInfo filename ct y
214+ let y' = (name, fi)
215+ (xs, ys) <-
216+ if wasFound
217+ then parsePieces sink bound
218+ else return ([], [])
219+ return (xs, y' : ys)
220+ Just (_ct, name, Nothing) -> do
221+ let seed = id
222+ let iter front bs = return $ front . (:) bs
223+ (front, wasFound) <-
224+ sinkTillBound bound iter seed
225+ let bs = S.concat $ front []
226+ let x' = (name, qsDecode bs)
227+ (xs, ys) <-
228+ if wasFound
229+ then parsePieces sink bound
230+ else return ([], [])
231+ return (x' : xs, ys)
232+ _ -> do
233+ -- ignore this part
234+ let seed = ()
235+ iter () _ = return ()
236+ ((), wasFound) <- sinkTillBound bound iter seed
237+ if wasFound
238+ then parsePieces sink bound
239+ else return ([], [])
240+ where
241+ contDisp = S8.pack "Content-Disposition"
242+ contType = S8.pack "Content-Type"
243+ parsePair s =
244+ let (x, y) = breakDiscard 58 s -- colon
245+ in (x, S.dropWhile (== 32) y) -- space
246+
247+data Bound = FoundBound S.ByteString S.ByteString
248+ | NoBound
249+ | PartialBound
250+ deriving (Eq, Show)
251+
252+findBound :: S.ByteString -> S.ByteString -> Bound
253+findBound b bs = go [0..S.length bs - 1]
254+ where
255+ go [] = NoBound
256+ go (i:is)
257+ | mismatch [0..S.length b - 1] [i..S.length bs - 1] = go is
258+ | otherwise =
259+ let endI = i + S.length b
260+ in if endI > S.length bs
261+ then PartialBound
262+ else FoundBound (S.take i bs) (S.drop endI bs)
263+ mismatch [] _ = False
264+ mismatch _ [] = False
265+ mismatch (x:xs) (y:ys)
266+ | S.index b x == S.index bs y = mismatch xs ys
267+ | otherwise = True
268+
269+sinkTillBound :: S.ByteString
270+ -> (x -> S.ByteString -> IO x)
271+ -> x
272+ -> Iteratee S.ByteString IO (x, Bool)
273+sinkTillBound bound iter seed = do
274+ mbs <- EL.head
275+ case mbs of
276+ Nothing -> return (seed, False)
277+ Just bs -> go bs
278+ where
279+ go bs =
280+ case findBound bound bs of
281+ FoundBound before after -> do
282+ let before' = killCRLF before
283+ seed' <- liftIO $ iter seed before'
284+ yield () $ E.Chunks [after]
285+ return (seed', True)
286+ PartialBound -> do
287+ mbs <- EL.head
288+ case mbs of
289+ Nothing -> do
290+ seed' <- liftIO $ iter seed bs
291+ return (seed', False)
292+ Just bs2 -> do
293+ let bs' = bs `S.append` bs2
294+ yield () $ E.Chunks [bs']
295+ sinkTillBound bound iter seed
296+ NoBound -> do
297+ mbs <- EL.head
298+ case mbs of
299+ Nothing -> do
300+ seed' <- liftIO $ iter seed bs
301+ sinkTillBound bound iter seed'
302+ Just bs' -> do
303+ -- this funny bit is to catch when there's a
304+ -- newline at the end of the previous chunk
305+ (seed', bs'') <-
306+ if not (S8.null bs) && S8.last bs `elem` "\n\r"
307+ then do
308+ let (front, back) =
309+ S.splitAt (S.length bs - 2) bs
310+ seed' <- liftIO $ iter seed front
311+ return (seed', back `S.append` bs')
312+ else do
313+ seed' <- liftIO $ iter seed bs
314+ return (seed', bs')
315+ yield () $ E.Chunks [bs'']
316+ sinkTillBound bound iter seed'
317+ {-
318+ NoBound -> do
319+ case msrc of
320+ Just (bs', src') -> do
321+ -}
322+
323+parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]
324+parseAttrs = map go . S.split 59 -- semicolon
325+ where
326+ tw = S.dropWhile (== 32) -- space
327+ dq s = if S.length s > 2 && S.head s == 34 && S.last s == 34 -- quote
328+ then S.tail $ S.init s
329+ else s
330+ go s =
331+ let (x, y) = breakDiscard 61 s -- equals sign
332+ in (tw x, dq $ tw y)
333+
334+killCRLF :: S.ByteString -> S.ByteString
335+killCRLF bs
336+ | S.null bs || S.last bs /= 10 = bs -- line feed
337+ | otherwise = killCR $ S.init bs
338+
339+killCR :: S.ByteString -> S.ByteString
340+killCR bs
341+ | S.null bs || S.last bs /= 13 = bs -- carriage return
342+ | otherwise = S.init bs
wai-extra/Network/Wai/Zlib.hsnew file+41
@@ -0,0 +1,41 @@
1+module Network.Wai.Zlib (compress) where
2+
3+import Prelude hiding (head)
4+import Data.Enumerator
5+ ( Enumeratee, checkDone, Stream (..)
6+ , (>>==), ($$), joinI
7+ )
8+import Data.Enumerator.List (head)
9+import Blaze.ByteString.Builder (Builder, fromByteString)
10+import Blaze.ByteString.Builder.Enumerator (builderToByteString)
11+import Control.Monad.IO.Class (liftIO)
12+
13+import Codec.Zlib
14+
15+-- Note: this function really should return a stream of ByteStrings, but the
16+-- WAI protocol needs Builders anyway.
17+compress :: Enumeratee Builder Builder IO a
18+compress step0 = joinI $ builderToByteString $$ do
19+ def <- liftIO $ initDeflate 7 $ WindowBits 31
20+ loop def step0
21+ where
22+ loop def = checkDone $ step def
23+ step def k = do
24+ minput <- head
25+ case minput of
26+ Nothing -> do
27+ bss <- liftIO $ finishDeflate def drain
28+ k (Chunks bss) >>== return
29+ Just input -> do
30+ bss <- liftIO $ withDeflateInput def input drain
31+ case bss of
32+ [] -> step def k
33+ _ -> k (Chunks bss) >>== loop def
34+ drain =
35+ go id
36+ where
37+ go front mbs' = do
38+ mbs <- mbs'
39+ case mbs of
40+ Nothing -> return $ map fromByteString $ front []
41+ Just bs -> go (front . (:) bs) mbs'
wai-extra/READMEnew file+1
@@ -0,0 +1 @@
1+Provides some basic WAI handlers and middleware.
wai-extra/Setup.lhsnew file+7
@@ -0,0 +1,7 @@
1+#!/usr/bin/env runhaskell
2+
3+> module Main where
4+> import Distribution.Simple
5+
6+> main :: IO ()
7+> main = defaultMain
wai-extra/proxy.hsnew file+25
@@ -0,0 +1,25 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+import qualified Network.HTTP.Enumerator as H
3+import qualified Network.Wai as W
4+import Network.Wai.Middleware.Gzip (gzip)
5+import Network.Wai.Handler.SimpleServer (run)
6+import qualified Data.ByteString.Char8 as S8
7+import qualified Data.ByteString.Lazy.Char8 ()
8+import Data.Enumerator (($$), joinI, run_)
9+import Blaze.ByteString.Builder (fromByteString)
10+import qualified Data.Enumerator as E
11+
12+main :: IO ()
13+main = run 3000 $ gzip False app
14+
15+app :: W.Application
16+app W.Request { W.pathInfo = path } =
17+ case H.parseUrl $ "http://wiki.yesodweb.com" ++ S8.unpack path of
18+ Nothing -> return notFound
19+ Just hreq -> return $ W.ResponseEnumerator $ run_ . H.http hreq . go
20+ where
21+ go f s h = joinI $ E.map fromByteString $$ f s $ filter safe h
22+ safe (x, _) = not $ x `elem` ["Content-Encoding", "Transfer-Encoding"]
23+
24+notFound :: W.Response
25+notFound = W.ResponseLBS W.status404 [("Content-Type", "text/plain")] "Not found"
wai-extra/runtests.hsnew file+396
@@ -0,0 +1,396 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+import Test.Framework (defaultMain, testGroup, Test)
3+import Test.Framework.Providers.HUnit
4+import Test.HUnit hiding (Test)
5+
6+import Network.Wai
7+import Network.Wai.Test
8+import Network.Wai.Parse
9+import qualified Data.ByteString as S
10+import qualified Data.ByteString.Char8 as S8
11+import qualified Data.ByteString.Lazy.Char8 as L8
12+import qualified Data.ByteString.Lazy as L
13+import Control.Arrow
14+
15+import Network.Wai.Middleware.Jsonp
16+import Network.Wai.Middleware.Gzip
17+import Network.Wai.Middleware.Vhost
18+import Network.Wai.Middleware.Autohead
19+import Network.Wai.Middleware.MethodOverride
20+import Network.Wai.Middleware.AcceptOverride
21+import Network.Wai.Middleware.Debug (debug)
22+import Codec.Compression.GZip (decompress)
23+
24+import Data.Enumerator (run_, enumList, ($$), Iteratee)
25+import Data.Enumerator.Binary (enumFile)
26+import Control.Monad.IO.Class (liftIO)
27+import Data.Maybe (fromMaybe)
28+import Network.HTTP.Types (parseSimpleQuery, status200)
29+
30+main :: IO ()
31+main = defaultMain [testSuite]
32+
33+testSuite :: Test
34+testSuite = testGroup "Network.Wai.Parse"
35+ [ testCase "parseQueryString" caseParseQueryString
36+ , testCase "parseQueryString with question mark" caseParseQueryStringQM
37+ , testCase "parseHttpAccept" caseParseHttpAccept
38+ , testCase "parseRequestBody" caseParseRequestBody
39+ , testCase "findBound" caseFindBound
40+ , testCase "sinkTillBound" caseSinkTillBound
41+ , testCase "killCR" caseKillCR
42+ , testCase "killCRLF" caseKillCRLF
43+ , testCase "takeLine" caseTakeLine
44+ , testCase "jsonp" caseJsonp
45+ , testCase "gzip" caseGzip
46+ , testCase "gzip not for MSIE" caseGzipMSIE
47+ , testCase "vhost" caseVhost
48+ , testCase "autohead" caseAutohead
49+ , testCase "method override" caseMethodOverride
50+ , testCase "accept override" caseAcceptOverride
51+ , testCase "dalvik multipart" caseDalvikMultipart
52+ , testCase "debug request body" caseDebugRequestBody
53+ ]
54+
55+caseParseQueryString :: Assertion
56+caseParseQueryString = do
57+ let go l r =
58+ map (S8.pack *** S8.pack) l @=? parseSimpleQuery (S8.pack r)
59+
60+ go [] ""
61+ go [("foo", "")] "foo"
62+ go [("foo", "bar")] "foo=bar"
63+ go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin"
64+ go [("%Q", "")] "%Q"
65+ go [("%1Q", "")] "%1Q"
66+ go [("%1", "")] "%1"
67+ go [("/", "")] "%2F"
68+ go [("/", "")] "%2f"
69+ go [("foo bar", "")] "foo+bar"
70+
71+caseParseQueryStringQM :: Assertion
72+caseParseQueryStringQM = do
73+ let go l r =
74+ map (S8.pack *** S8.pack) l
75+ @=? parseSimpleQuery (S8.pack $ '?' : r)
76+
77+ go [] ""
78+ go [("foo", "")] "foo"
79+ go [("foo", "bar")] "foo=bar"
80+ go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin"
81+ go [("%Q", "")] "%Q"
82+ go [("%1Q", "")] "%1Q"
83+ go [("%1", "")] "%1"
84+ go [("/", "")] "%2F"
85+ go [("/", "")] "%2f"
86+ go [("foo bar", "")] "foo+bar"
87+
88+caseParseHttpAccept :: Assertion
89+caseParseHttpAccept = do
90+ let input = "text/plain; q=0.5, text/html, text/x-dvi; q=0.8, text/x-c"
91+ expected = ["text/html", "text/x-c", "text/x-dvi", "text/plain"]
92+ expected @=? parseHttpAccept input
93+
94+parseRequestBody' :: Sink ([S8.ByteString] -> [S8.ByteString]) L.ByteString
95+ -> SRequest
96+ -> Iteratee S.ByteString IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)])
97+parseRequestBody' sink (SRequest req bod) =
98+ enumList 1 (L.toChunks bod) $$ parseRequestBody sink req
99+
100+caseParseRequestBody :: Assertion
101+caseParseRequestBody = run_ t where
102+ content2 = S8.pack $
103+ "--AaB03x\n" ++
104+ "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n" ++
105+ "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
106+ "This is a file.\n" ++
107+ "It has two lines.\n" ++
108+ "--AaB03x\n" ++
109+ "Content-Disposition: form-data; name=\"title\"\n" ++
110+ "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
111+ "A File\n" ++
112+ "--AaB03x\n" ++
113+ "Content-Disposition: form-data; name=\"summary\"\n" ++
114+ "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
115+ "This is my file\n" ++
116+ "file test\n" ++
117+ "--AaB03x--"
118+ 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"
119+ t = do
120+ let content1 = "foo=bar&baz=bin"
121+ let ctype1 = "application/x-www-form-urlencoded"
122+ result1 <- parseRequestBody' lbsSink $ toRequest ctype1 content1
123+ liftIO $ assertEqual "parsing post x-www-form-urlencoded"
124+ (map (S8.pack *** S8.pack) [("foo", "bar"), ("baz", "bin")], [])
125+ result1
126+
127+ let ctype2 = "multipart/form-data; boundary=AaB03x"
128+ result2 <- parseRequestBody' lbsSink $ toRequest ctype2 content2
129+ let expectedsmap2 =
130+ [ ("title", "A File")
131+ , ("summary", "This is my file\nfile test")
132+ ]
133+ let textPlain = S8.pack $ "text/plain; charset=iso-8859-1"
134+ let expectedfile2 =
135+ [(S8.pack "document", FileInfo (S8.pack "b.txt") textPlain $ L8.pack
136+ "This is a file.\nIt has two lines.")]
137+ let expected2 = (map (S8.pack *** S8.pack) expectedsmap2, expectedfile2)
138+ liftIO $ assertEqual "parsing post multipart/form-data"
139+ expected2
140+ result2
141+
142+ let ctype3 = "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"
143+ result3 <- parseRequestBody' lbsSink $ toRequest ctype3 content3
144+ let expectedsmap3 = []
145+ let expectedfile3 = [(S8.pack "yaml", FileInfo (S8.pack "README") (S8.pack "application/octet-stream") $
146+ L8.pack "Photo blog using Hack.\n")]
147+ let expected3 = (expectedsmap3, expectedfile3)
148+ liftIO $ assertEqual "parsing actual post multipart/form-data"
149+ expected3
150+ result3
151+
152+ result2' <- parseRequestBody' lbsSink $ toRequest' ctype2 content2
153+ liftIO $ assertEqual "parsing post multipart/form-data 2"
154+ expected2
155+ result2'
156+
157+ result3' <- parseRequestBody' lbsSink $ toRequest' ctype3 content3
158+ liftIO $ assertEqual "parsing actual post multipart/form-data 2"
159+ expected3
160+ result3'
161+
162+toRequest :: S8.ByteString -> S8.ByteString -> SRequest
163+toRequest ctype content = SRequest (Request
164+ { requestHeaders = [("Content-Type", ctype)]
165+ , requestMethod = "POST"
166+ , rawPathInfo = ""
167+ , rawQueryString = ""
168+ }) (L.fromChunks [content])
169+
170+toRequest' :: S8.ByteString -> S8.ByteString -> SRequest
171+toRequest' ctype content = SRequest (Request
172+ { requestHeaders = [("Content-Type", ctype)]
173+ }) (L.fromChunks $ map S.singleton $ S.unpack content)
174+
175+caseFindBound :: Assertion
176+caseFindBound = do
177+ findBound (S8.pack "def") (S8.pack "abcdefghi") @?=
178+ FoundBound (S8.pack "abc") (S8.pack "ghi")
179+ findBound (S8.pack "def") (S8.pack "ABC") @?= NoBound
180+ findBound (S8.pack "def") (S8.pack "abcd") @?= PartialBound
181+ findBound (S8.pack "def") (S8.pack "abcdE") @?= NoBound
182+ findBound (S8.pack "def") (S8.pack "abcdEdef") @?=
183+ FoundBound (S8.pack "abcdE") (S8.pack "")
184+
185+caseSinkTillBound :: Assertion
186+caseSinkTillBound = do
187+ let iter () _ = return ()
188+ let src = S8.pack "this is some text"
189+ bound1 = S8.pack "some"
190+ bound2 = S8.pack "some!"
191+ let enum = enumList 1 [src]
192+ let helper _ _ = return ()
193+ (_, res1) <- run_ $ enum $$ sinkTillBound bound1 helper ()
194+ res1 @?= True
195+ (_, res2) <- run_ $ enum $$ sinkTillBound bound2 helper ()
196+ res2 @?= False
197+
198+caseKillCR :: Assertion
199+caseKillCR = do
200+ "foo" @=? killCR "foo"
201+ "foo" @=? killCR "foo\r"
202+ "foo\r\n" @=? killCR "foo\r\n"
203+ "foo\r'" @=? killCR "foo\r'"
204+
205+caseKillCRLF :: Assertion
206+caseKillCRLF = do
207+ "foo" @=? killCRLF "foo"
208+ "foo\r" @=? killCRLF "foo\r"
209+ "foo" @=? killCRLF "foo\r\n"
210+ "foo\r'" @=? killCRLF "foo\r'"
211+ "foo" @=? killCRLF "foo\n"
212+
213+caseTakeLine :: Assertion
214+caseTakeLine = do
215+ helper "foo\nbar\nbaz" "foo"
216+ helper "foo\r\nbar\nbaz" "foo"
217+ helper "foo\nbar\r\nbaz" "foo"
218+ helper "foo\rbar\r\nbaz" "foo\rbar"
219+ where
220+ helper haystack needle = do
221+ x <- run_ $ enumList 1 [haystack] $$ takeLine
222+ Just needle @=? x
223+
224+jsonpApp = jsonp $ const $ return $ responseLBS
225+ status200
226+ [("Content-Type", "application/json")]
227+ "{\"foo\":\"bar\"}"
228+
229+caseJsonp :: Assertion
230+caseJsonp = flip runSession jsonpApp $ do
231+ sres1 <- request Request
232+ { queryString = [("callback", Just "test")]
233+ , requestHeaders = [("Accept", "text/javascript")]
234+ }
235+ assertContentType "text/javascript" sres1
236+ assertBody "test({\"foo\":\"bar\"})" sres1
237+
238+ sres2 <- request Request
239+ { queryString = [("call_back", Just "test")]
240+ , requestHeaders = [("Accept", "text/javascript")]
241+ }
242+ assertContentType "application/json" sres2
243+ assertBody "{\"foo\":\"bar\"}" sres2
244+
245+ sres3 <- request Request
246+ { queryString = [("callback", Just "test")]
247+ , requestHeaders = [("Accept", "text/html")]
248+ }
249+ assertContentType "application/json" sres3
250+ assertBody "{\"foo\":\"bar\"}" sres3
251+
252+gzipApp = gzip True $ const $ return $ responseLBS status200 [] "test"
253+
254+caseGzip :: Assertion
255+caseGzip = flip runSession gzipApp $ do
256+ sres1 <- request Request
257+ { requestHeaders = [("Accept-Encoding", "gzip")]
258+ }
259+ assertHeader "Content-Encoding" "gzip" sres1
260+ liftIO $ decompress (simpleBody sres1) @?= "test"
261+
262+ sres2 <- request Request
263+ { requestHeaders = []
264+ }
265+ assertNoHeader "Content-Encoding" sres2
266+ assertBody "test" sres2
267+
268+caseGzipMSIE :: Assertion
269+caseGzipMSIE = flip runSession gzipApp $ do
270+ sres1 <- request Request
271+ { requestHeaders =
272+ [ ("Accept-Encoding", "gzip")
273+ , ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)")
274+ ]
275+ }
276+ assertNoHeader "Content-Encoding" sres1
277+ liftIO $ simpleBody sres1 @?= "test"
278+
279+vhostApp1 = const $ return $ responseLBS status200 [] "app1"
280+vhostApp2 = const $ return $ responseLBS status200 [] "app2"
281+vhostApp = vhost
282+ [ ((== "foo.com") . serverName, vhostApp1)
283+ ]
284+ vhostApp2
285+
286+caseVhost = flip runSession vhostApp $ do
287+ sres1 <- request Request
288+ { serverName = "foo.com"
289+ }
290+ assertBody "app1" sres1
291+
292+ sres2 <- request Request
293+ { serverName = "bar.com"
294+ }
295+ assertBody "app2" sres2
296+
297+autoheadApp = autohead $ const $ return $ responseLBS status200
298+ [("Foo", "Bar")] "body"
299+
300+caseAutohead = flip runSession autoheadApp $ do
301+ sres1 <- request Request
302+ { requestMethod = "GET"
303+ }
304+ assertHeader "Foo" "Bar" sres1
305+ assertBody "body" sres1
306+
307+ sres1 <- request Request
308+ { requestMethod = "HEAD"
309+ }
310+ assertHeader "Foo" "Bar" sres1
311+ assertBody "" sres1
312+
313+moApp = methodOverride $ \req -> return $ responseLBS status200
314+ [("Method", requestMethod req)] ""
315+
316+caseMethodOverride = flip runSession moApp $ do
317+ sres1 <- request Request
318+ { requestMethod = "GET"
319+ , queryString = []
320+ }
321+ assertHeader "Method" "GET" sres1
322+
323+ sres2 <- request Request
324+ { requestMethod = "POST"
325+ , queryString = []
326+ }
327+ assertHeader "Method" "POST" sres2
328+
329+ sres3 <- request Request
330+ { requestMethod = "POST"
331+ , queryString = [("_method", Just "PUT")]
332+ }
333+ assertHeader "Method" "PUT" sres3
334+
335+aoApp = acceptOverride $ \req -> return $ responseLBS status200
336+ [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""
337+
338+caseAcceptOverride = flip runSession aoApp $ do
339+ sres1 <- request Request
340+ { queryString = []
341+ , requestHeaders = [("Accept", "foo")]
342+ }
343+ assertHeader "Accept" "foo" sres1
344+
345+ sres2 <- request Request
346+ { queryString = []
347+ , requestHeaders = [("Accept", "bar")]
348+ }
349+ assertHeader "Accept" "bar" sres2
350+
351+ sres3 <- request Request
352+ { queryString = [("_accept", Just "baz")]
353+ , requestHeaders = [("Accept", "bar")]
354+ }
355+ assertHeader "Accept" "baz" sres3
356+
357+caseDalvikMultipart = do
358+ let headers =
359+ [ ("content-length", "12098")
360+ , ("content-type", "multipart/form-data;boundary=*****")
361+ , ("GATEWAY_INTERFACE", "CGI/1.1")
362+ , ("PATH_INFO", "/")
363+ , ("QUERY_STRING", "")
364+ , ("REMOTE_ADDR", "192.168.1.115")
365+ , ("REMOTE_HOST", "ganjizza")
366+ , ("REQUEST_URI", "http://192.168.1.115:3000/")
367+ , ("REQUEST_METHOD", "POST")
368+ , ("HTTP_CONNECTION", "Keep-Alive")
369+ , ("HTTP_COOKIE", "_SESSION=fgUGM5J/k6mGAAW+MMXIJZCJHobw/oEbb6T17KQN0p9yNqiXn/m/ACrsnRjiCEgqtG4fogMUDI+jikoFGcwmPjvuD5d+MDz32iXvDdDJsFdsFMfivuey2H+n6IF6yFGD")
370+ , ("HTTP_USER_AGENT", "Dalvik/1.1.0 (Linux; U; Android 2.1-update1; sdk Build/ECLAIR)")
371+ , ("HTTP_HOST", "192.168.1.115:3000")
372+ , ("HTTP_ACCEPT", "*, */*")
373+ , ("HTTP_VERSION", "HTTP/1.1")
374+ , ("REQUEST_PATH", "/")
375+ ]
376+ let request = Request
377+ { requestHeaders = headers
378+ }
379+ (params, files) <- run_ $ enumFile "test/dalvik-request" $$ parseRequestBody lbsSink request
380+ lookup "scannedTime" params @?= Just "1.298590056748E9"
381+ lookup "geoLong" params @?= Just "0"
382+ lookup "geoLat" params @?= Just "0"
383+ length files @?= 1
384+
385+caseDebugRequestBody :: 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+ ] ""
wai-extra/test/dalvik-requestnew file

Binary file not shown.

wai-extra/test/jsonnew file+1
@@ -0,0 +1 @@
1+{"data":"this is some data"}
wai-extra/test/sample.hsnew file+25
@@ -0,0 +1,25 @@
1+import Data.ByteString.Char8 (unpack, pack)
2+import Data.ByteString.Lazy (fromChunks)
3+import Network.Wai
4+import Network.Wai.Enumerator
5+import Network.Wai.Middleware.Gzip
6+import Network.Wai.Middleware.Jsonp
7+import Network.Wai.Middleware.CleanPath
8+import Network.Wai.Handler.SimpleServer
9+
10+app :: [String] -> Application
11+app [] _ = return $ Response Status200 [] $ Right $ fromLBS
12+ $ fromChunks $ flip map [1..10000] $ \i -> pack $
13+ concat
14+ [ "<p>Just this same paragraph again. "
15+ , show i
16+ , "</p>"
17+ ]
18+app ["test.html"] _ = return $ Response Status200 [] $ Left "test.html"
19+app ["json"] _ =return $ Response Status200
20+ [(ContentType, pack "application/json")]
21+ $ Left "json"
22+app _ _ = return $ Response Status404 [] $ Left "../LICENSE"
23+
24+main :: IO ()
25+main = run 3000 $ jsonp $ gzip $ cleanPath app
wai-extra/test/test.htmlnew file+17
@@ -0,0 +1,17 @@
1+<!DOCTYPE html>
2+<html>
3+ <head>
4+ <script src="http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.js"></script>
5+ <script>
6+ $(function(){
7+ $.getJSON("/json?callback=?", function(o){
8+ $("#dest").html(o.data);
9+ });
10+ });
11+ </script>
12+ </head>
13+ <body>
14+ There should be some content loaded below:
15+ <div id="dest"></div>
16+ </body>
17+</html>
wai-extra/wai-extra.cabalnew file+47
@@ -0,0 +1,47 @@
1+Name: wai-extra
2+Version: 0.4.0.3
3+Synopsis: Provides some basic WAI handlers and middleware.
4+Description: The goal here is to provide common features without many dependencies.
5+License: BSD3
6+License-file: LICENSE
7+Author: Michael Snoyman
8+Maintainer: michael@snoyman.com
9+Homepage: http://github.com/snoyberg/wai-extra
10+Category: Web
11+Build-Type: Simple
12+Cabal-Version: >=1.6
13+Stability: Stable
14+
15+Library
16+ Build-Depends: base >= 3 && < 5,
17+ bytestring >= 0.9 && < 0.10,
18+ wai >= 0.4 && < 0.5,
19+ old-locale >= 1.0 && < 1.1,
20+ time >= 1.1.4 && < 1.3,
21+ network >= 2.2.1.5 && < 2.4,
22+ directory >= 1.0.1 && < 1.2,
23+ zlib-bindings >= 0.0 && < 0.1,
24+ blaze-builder-enumerator >= 0.2 && < 0.3,
25+ transformers >= 0.2 && < 0.3,
26+ enumerator >= 0.4.7 && < 0.5,
27+ blaze-builder >= 0.2.1.3 && < 0.4,
28+ http-types >= 0.6 && < 0.7,
29+ text >= 0.5 && < 1.0,
30+ case-insensitive >= 0.2 && < 0.4
31+ Exposed-modules: Network.Wai.Handler.CGI
32+ Network.Wai.Middleware.AcceptOverride
33+ Network.Wai.Middleware.Autohead
34+ Network.Wai.Middleware.CleanPath
35+ Network.Wai.Middleware.Debug
36+ Network.Wai.Middleware.Gzip
37+ Network.Wai.Middleware.Jsonp
38+ Network.Wai.Middleware.MethodOverride
39+ Network.Wai.Middleware.Rewrite
40+ Network.Wai.Middleware.Vhost
41+ Network.Wai.Zlib
42+ Network.Wai.Parse
43+ ghc-options: -Wall
44+
45+source-repository head
46+ type: git
47+ location: git://github.com/snoyberg/wai-extra.git