git.iko.soy/typeable/wai
on master help sign in
Fixed a bunch of middlewares
fdcc6aaMichael Snoyman
wai-extra/Network/Wai/Middleware/Gzip.hs+71−24
compare with master
unifiedsplit
@@ -37,6 +37,14 @@ import Blaze.ByteString.Builder (fromByteString)
37import Control.Exception (try, SomeException)
37import Control.Exception (try, SomeException)
38import qualified Data.Set as Set
38import qualified Data.Set as Set
39import Network.Wai.Internal
39import Network.Wai.Internal
40+import qualified Data.Streaming.Blaze as B
41+import qualified Data.Streaming.Zlib as Z
42+import qualified Blaze.ByteString.Builder as Blaze
43+import Control.Monad (unless)
44+import Data.Function (fix)
45+import Control.Exception (throwIO)
46+import qualified System.IO as IO
47+import Data.ByteString.Lazy.Internal (defaultChunkSize)
40
48
41data GzipSettings = GzipSettings
49data GzipSettings = GzipSettings
42 { gzipFiles :: GzipFiles
50 { gzipFiles :: GzipFiles
@@ -69,20 +77,19 @@ defaultCheckMime bs =
69--
77--
70-- * Only compress if the response is above a certain size.
78-- * Only compress if the response is above a certain size.
71gzip :: GzipSettings -> Middleware
79gzip :: GzipSettings -> Middleware
72−gzip set app env = do
80+gzip set app env sendResponse = app env $ \res ->
73− res <- app env
74 case res of
81 case res of
75− ResponseFile{} | gzipFiles set == GzipIgnore -> return res
82+ ResponseFile{} | gzipFiles set == GzipIgnore -> sendResponse res
76 _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res)
83 _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res)
77 then
84 then
78 case (res, gzipFiles set) of
85 case (res, gzipFiles set) of
79 (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->
86 (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->
80 case lookup "content-type" hs of
87 case lookup "content-type" hs of
81 Just m
88 Just m
82− | gzipCheckMime set m -> liftIO $ compressFile s hs file cache
89+ | gzipCheckMime set m -> compressFile s hs file cache sendResponse
83− _ -> return res
90+ _ -> sendResponse res
84− _ -> return $ compressE set res
91+ _ -> compressE set res sendResponse
85− else return res
92+ else sendResponse res
86 where
93 where
87 enc = fromMaybe [] $ (splitCommas . S8.unpack)
94 enc = fromMaybe [] $ (splitCommas . S8.unpack)
88 `fmap` lookup "Accept-Encoding" (requestHeaders env)
95 `fmap` lookup "Accept-Encoding" (requestHeaders env)
@@ -90,22 +97,38 @@ gzip set app env = do
90 isMSIE6 = "MSIE 6" `S.isInfixOf` ua
97 isMSIE6 = "MSIE 6" `S.isInfixOf` ua
91 isEncoded res = isJust $ lookup "Content-Encoding" $ responseHeaders res
98 isEncoded res = isJust $ lookup "Content-Encoding" $ responseHeaders res
92
99
93−compressFile :: Status -> [Header] -> FilePath -> FilePath -> IO Response
100+compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a
94−compressFile s hs file cache = do
101+compressFile s hs file cache sendResponse = do
95 e <- doesFileExist tmpfile
102 e <- doesFileExist tmpfile
96 if e
103 if e
97 then onSucc
104 then onSucc
98 else do
105 else do
99 createDirectoryIfMissing True cache
106 createDirectoryIfMissing True cache
100− x <-
107+ x <- try $
101− try $ runResourceT $ CB.sourceFile file
108+ IO.withBinaryFile file IO.ReadMode $ \inH ->
102− C.$$ CZ.gzip C.=$ CB.sinkFile tmpfile
109+ IO.withBinaryFile tmpfile IO.WriteMode $ \outH -> do
110+ deflate <- Z.initDeflate 7 $ Z.WindowBits 31
111+ -- FIXME this code should write to a temporary file, then
112+ -- rename to the final file
113+ let goPopper popper = fix $ \loop -> do
114+ res <- popper
115+ case res of
116+ Z.PRDone -> return ()
117+ Z.PRNext bs -> do
118+ S.hPut outH bs
119+ loop
120+ Z.PRError e -> throwIO e
121+ fix $ \loop -> do
122+ bs <- S.hGetSome inH defaultChunkSize
123+ unless (S.null bs) $ do
124+ Z.feedDeflate deflate bs >>= goPopper
125+ loop
126+ goPopper $ Z.finishDeflate deflate
103− either onErr (const onSucc) x
127+ either onErr (const onSucc) (x :: Either SomeException ()) -- FIXME bad! don't catch all exceptions like that!
104 where
128 where
105− onSucc = return $ ResponseFile s (fixHeaders hs) tmpfile Nothing
129+ onSucc = sendResponse $ responseFile s (fixHeaders hs) tmpfile Nothing
106
130
107− onErr :: SomeException -> IO Response
108− onErr = const $ return $ ResponseFile s hs file Nothing -- FIXME log the error message
131+ onErr _ = sendResponse $ responseFile s hs file Nothing -- FIXME log the error message
109
132
110 tmpfile = cache ++ '/' : map safe file
133 tmpfile = cache ++ '/' : map safe file
111 safe c
134 safe c
@@ -118,18 +141,42 @@ compressFile s hs file cache = do
118
141
119compressE :: GzipSettings
142compressE :: GzipSettings
120 -> Response
143 -> Response
121− -> Response
144+ -> (Response -> IO a)
145+ -> IO a
122−compressE set res =
146+compressE set res sendResponse =
123 case lookup "content-type" hs of
147 case lookup "content-type" hs of
124 Just m | gzipCheckMime set m ->
148 Just m | gzipCheckMime set m ->
125 let hs' = fixHeaders hs
149 let hs' = fixHeaders hs
126− in ResponseSource s hs' $ \f -> wb $ \b -> f $
150+ in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do
127− b C.$= builderToByteStringFlush
151+ (blazeRecv, blazeFinish) <- B.newBlazeRecv B.defaultStrategy
128− C.$= CZ.compressFlush 1 (CZ.WindowBits 31)
152+ deflate <- Z.initDeflate 1 (Z.WindowBits 31)
153+ let sendBuilder builder = do
154+ popper <- blazeRecv builder
155+ fix $ \loop -> do
156+ bs <- popper
157+ unless (S.null bs) $ do
158+ sendBS bs
159+ loop
160+ sendBS bs = Z.feedDeflate deflate bs >>= deflatePopper
161+ flushBuilder = do
162+ sendBuilder Blaze.flush
163+ deflatePopper $ Z.flushDeflate deflate
164+ flush
165+ deflatePopper popper = fix $ \loop -> do
166+ res <- popper
167+ case res of
168+ Z.PRDone -> return ()
169+ Z.PRNext bs' -> do
129− C.$= CL.map (fmap fromByteString)
170+ sendChunk $ fromByteString bs'
171+ loop
172+ Z.PRError e -> throwIO e
173+
174+ body sendBuilder flushBuilder
175+ sendBuilder Blaze.flush
176+ deflatePopper $ Z.finishDeflate deflate
130− _ -> res
177+ _ -> sendResponse res
131 where
178 where
132− (s, hs, wb) = responseToSource res
179+ (s, hs, wb) = responseToStream res
133
180
134-- Remove Content-Length header, since we will certainly have a
181-- Remove Content-Length header, since we will certainly have a
135-- different length after gzip compression.
182-- different length after gzip compression.
wai-extra/Network/Wai/Middleware/HttpAuth.hs+4−4
@@ -32,12 +32,12 @@ type CheckCreds = ByteString
32basicAuth :: CheckCreds
32basicAuth :: CheckCreds
33 -> AuthSettings
33 -> AuthSettings
34 -> Middleware
34 -> Middleware
35−basicAuth checkCreds AuthSettings {..} app req = do
35+basicAuth checkCreds AuthSettings {..} app req sendResponse = do
36 isProtected <- authIsProtected req
36 isProtected <- authIsProtected req
37 allowed <- if isProtected then check else return True
37 allowed <- if isProtected then check else return True
38 if allowed
38 if allowed
39− then app req
39+ then app req sendResponse
40− else authOnNoAuth authRealm req
40+ else authOnNoAuth authRealm req sendResponse
41 where
41 where
42 check =
42 check =
43 case lookup "Authorization" $ requestHeaders req of
43 case lookup "Authorization" $ requestHeaders req of
@@ -83,7 +83,7 @@ data AuthSettings = AuthSettings
83instance IsString AuthSettings where
83instance IsString AuthSettings where
84 fromString s = AuthSettings
84 fromString s = AuthSettings
85 { authRealm = fromString s
85 { authRealm = fromString s
86− , authOnNoAuth = \realm _req -> return $ responseLBS
86+ , authOnNoAuth = \realm _req f -> f $ responseLBS
87 status401
87 status401
88 [ ("Content-Type", "text/plain")
88 [ ("Content-Type", "text/plain")
89 , ("WWW-Authenticate", S.concat
89 , ("WWW-Authenticate", S.concat
wai-extra/Network/Wai/Middleware/Jsonp.hs+13−18
@@ -36,7 +36,7 @@ import Network.HTTP.Types (Status)
36-- having a content type of \"text\/javascript\" and calling the specified
36-- having a content type of \"text\/javascript\" and calling the specified
37-- callback function.
37-- callback function.
38jsonp :: Middleware
38jsonp :: Middleware
39−jsonp app env = do
39+jsonp app env sendResponse = do
40 let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env
40 let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env
41 let callback :: Maybe B8.ByteString
41 let callback :: Maybe B8.ByteString
42 callback =
42 callback =
@@ -51,15 +51,15 @@ jsonp app env = do
51 "application/json"
51 "application/json"
52 $ requestHeaders env
52 $ requestHeaders env
53 }
53 }
54− res <- app env'
54+ app env' $ \res ->
55− return $ case callback of
55+ case callback of
56− Nothing -> res
56+ Nothing -> sendResponse res
57− Just c -> go c res
57+ Just c -> go c res
58 where
58 where
59 go c r@(ResponseBuilder s hs b) =
59 go c r@(ResponseBuilder s hs b) =
60− case checkJSON hs of
60+ sendResponse $ case checkJSON hs of
61 Nothing -> r
61 Nothing -> r
62− Just hs' -> ResponseBuilder s hs' $
62+ Just hs' -> responseBuilder s hs' $
63 copyByteString c
63 copyByteString c
64 `mappend` fromChar '('
64 `mappend` fromChar '('
65 `mappend` b
65 `mappend` b
@@ -67,9 +67,9 @@ jsonp app env = do
67 go c r =
67 go c r =
68 case checkJSON hs of
68 case checkJSON hs of
69 Just hs' -> addCallback c s hs' wb
69 Just hs' -> addCallback c s hs' wb
70− Nothing -> r
70+ Nothing -> sendResponse r
71 where
71 where
72− (s, hs, wb) = responseToSource r
72+ (s, hs, wb) = responseToStream r
73
73
74 checkJSON hs =
74 checkJSON hs =
75 case lookup "Content-Type" hs of
75 case lookup "Content-Type" hs of
@@ -79,16 +79,11 @@ jsonp app env = do
79 _ -> Nothing
79 _ -> Nothing
80 fixHeaders = changeVal "Content-Type" "text/javascript"
80 fixHeaders = changeVal "Content-Type" "text/javascript"
81
81
82− addCallback :: ByteString
83− -> Status
84− -> [(CI ByteString, ByteString)]
85− -> (forall b. WithSource IO (C.Flush Builder) b)
86− -> Response
87 addCallback cb s hs wb =
82 addCallback cb s hs wb =
88− ResponseSource s hs $ \f -> wb $ \b -> f $
83+ wb $ \body -> sendResponse $ responseStream s hs $ \sendChunk flush -> do
89− C.yield (C.Chunk $ copyByteString cb `mappend` fromChar '(')
84+ sendChunk $ copyByteString cb `mappend` fromChar '('
90− `mappend` b
85+ body sendChunk flush
91− `mappend` C.yield (C.Chunk $ fromChar ')')
86+ sendChunk $ fromChar ')'
92
87
93changeVal :: Eq a
88changeVal :: Eq a
94 => a
89 => a
wai-extra/Network/Wai/Middleware/MethodOverridePost.hs+13−8
@@ -10,7 +10,9 @@ module Network.Wai.Middleware.MethodOverridePost
10
10
11import Network.Wai
11import Network.Wai
12import Network.HTTP.Types (parseQuery)
12import Network.HTTP.Types (parseQuery)
13−import Data.Monoid (mconcat)
13+import Data.Monoid (mconcat, mempty)
14+import Data.IORef
15+import Data.ByteString.Lazy (toChunks)
14
16
15-- | Allows overriding of the HTTP request method via the _method post string parameter.
17-- | Allows overriding of the HTTP request method via the _method post string parameter.
16--
18--
@@ -24,13 +26,16 @@ import Data.Monoid (mconcat)
24-- * This middleware only applies when the initial request method is POST.
26-- * This middleware only applies when the initial request method is POST.
25--
27--
26methodOverridePost :: Middleware
28methodOverridePost :: Middleware
29+methodOverridePost app req send =
27−methodOverridePost app req = case (requestMethod req, lookup "Content-Type" (requestHeaders req)) of
30+ case (requestMethod req, lookup "Content-Type" (requestHeaders req)) of
28− ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= app
31+ ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send
29− _ -> app req
32+ _ -> app req send
30
33
31setPost :: Request -> IO Request
34setPost :: Request -> IO Request
32setPost req = do
35setPost req = do
33− body <- lazyConsume (requestBody req)
36+ body <- (mconcat . toChunks) `fmap` lazyRequestBody req
37+ ref <- newIORef body
38+ let rb = atomicModifyIORef ref $ \bs -> (mempty, bs)
34− case parseQuery (mconcat body) of
39+ case parseQuery body of
35− (("_method", Just newmethod):_) -> return $ req {requestBody = sourceList body, requestMethod = newmethod}
40+ (("_method", Just newmethod):_) -> return $ req {requestBody = rb, requestMethod = newmethod}
36− _ -> return $ req {requestBody = sourceList body}
41+ _ -> return $ req {requestBody = rb}
wai-extra/Network/Wai/Middleware/Rewrite.hs+2−2
@@ -13,10 +13,10 @@ import Network.HTTP.Types as H
13
13
14-- | rewrite based on your own conversion rules
14-- | rewrite based on your own conversion rules
15rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware
15rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware
16−rewrite convert app req = do
16+rewrite convert app req sendResponse = do
17 newPathInfo <- liftIO $ convert (pathInfo req) (requestHeaders req)
17 newPathInfo <- liftIO $ convert (pathInfo req) (requestHeaders req)
18 let rawPInfo = TE.encodeUtf8 $ T.intercalate "/" newPathInfo
18 let rawPInfo = TE.encodeUtf8 $ T.intercalate "/" newPathInfo
19− app req { pathInfo = newPathInfo, rawPathInfo = rawPInfo }
19+ app req { pathInfo = newPathInfo, rawPathInfo = rawPInfo } sendResponse
20
20
21-- | rewrite based on your own conversion rules
21-- | rewrite based on your own conversion rules
22-- Example convert function:
22-- Example convert function:
wai-extra/Network/Wai/Middleware/Vhost.hs+3−3
@@ -20,10 +20,10 @@ redirectWWW home =
20 redirectIf home (maybe True (BS.isPrefixOf "www") . lookup "host" . requestHeaders)
20 redirectIf home (maybe True (BS.isPrefixOf "www") . lookup "host" . requestHeaders)
21
21
22redirectIf :: Text -> (Request -> Bool) -> Application -> Application
22redirectIf :: Text -> (Request -> Bool) -> Application -> Application
23−redirectIf home cond app req =
23+redirectIf home cond app req sendResponse =
24 if cond req
24 if cond req
25− then return $ redirectTo $ TE.encodeUtf8 home
25+ then sendResponse $ redirectTo $ TE.encodeUtf8 home
26− else app req
26+ else app req sendResponse
27
27
28redirectTo :: BS.ByteString -> Response
28redirectTo :: BS.ByteString -> Response
29redirectTo location = responseLBS H.status301
29redirectTo location = responseLBS H.status301
wai-extra/Network/Wai/Test.hs+10−7
@@ -24,6 +24,7 @@ module Network.Wai.Test
24 ) where
24 ) where
25
25
26import Network.Wai
26import Network.Wai
27+import Network.Wai.Internal (ResponseReceived (ResponseReceived))
27import Control.Monad.IO.Class (liftIO)
28import Control.Monad.IO.Class (liftIO)
28import Control.Monad.Trans.State (StateT, evalStateT)
29import Control.Monad.Trans.State (StateT, evalStateT)
29import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
30import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
@@ -47,9 +48,7 @@ import qualified Data.Text.Encoding as TE
47import Data.IORef
48import Data.IORef
48import Data.Monoid (mempty, mappend)
49import Data.Monoid (mempty, mappend)
49
50
50−type Session = ReaderT
51− (Request -> (Response -> IO SResponse) -> IO SResponse)
52− (StateT ClientState IO)
51+type Session = ReaderT Application (StateT ClientState IO)
53
52
54data ClientState = ClientState
53data ClientState = ClientState
55 { _clientCookies :: Map ByteString ByteString
54 { _clientCookies :: Map ByteString ByteString
@@ -104,17 +103,21 @@ srequest (SRequest req bod) = do
104 [] -> ([], S.empty)
103 [] -> ([], S.empty)
105 x:y -> (y, x)
104 x:y -> (y, x)
106 }
105 }
106+ liftIO $ do
107+ ref <- newIORef $ error "runResponse gave no result"
107− liftIO $ app req' runResponse
108+ ResponseReceived <- app req' (runResponse ref)
109+ readIORef ref
108 -- FIXME cookie processing
110 -- FIXME cookie processing
109 --return sres
111 --return sres
110
112
111−runResponse :: Response -> IO SResponse
113+runResponse :: IORef SResponse -> Response -> IO ResponseReceived
112−runResponse res = do
114+runResponse ref res = do
113 refBuilder <- newIORef mempty
115 refBuilder <- newIORef mempty
114 let add y = atomicModifyIORef refBuilder $ \x -> (x `mappend` y, ())
116 let add y = atomicModifyIORef refBuilder $ \x -> (x `mappend` y, ())
115 withBody $ \body -> body add (return ())
117 withBody $ \body -> body add (return ())
116 builder <- readIORef refBuilder
118 builder <- readIORef refBuilder
117− return $ SResponse s h $ toLazyByteString builder
119+ writeIORef ref $ SResponse s h $ toLazyByteString builder
120+ return ResponseReceived
118 where
121 where
119 (s, h, withBody) = responseToStream res
122 (s, h, withBody) = responseToStream res
120
123
wai-extra/Network/Wai/UrlMap.hs+7−9
@@ -50,13 +50,13 @@ instance Alternative UrlMap' where
50 empty = UrlMap' empty
50 empty = UrlMap' empty
51 (UrlMap' xs) <|> (UrlMap' ys) = UrlMap' (xs <|> ys)
51 (UrlMap' xs) <|> (UrlMap' ys) = UrlMap' (xs <|> ys)
52
52
53−type UrlMap = UrlMap' Application'
53+type UrlMap = UrlMap' Application
54
54
55-- | Mount an application under a given path. The ToApplication typeclass gives
55-- | Mount an application under a given path. The ToApplication typeclass gives
56-- you the option to pass either an 'Network.Wai.Application' or an 'UrlMap'
56-- you the option to pass either an 'Network.Wai.Application' or an 'UrlMap'
57-- as the second argument.
57-- as the second argument.
58mount' :: ToApplication a => Path -> a -> UrlMap
58mount' :: ToApplication a => Path -> a -> UrlMap
59−mount' prefix thing = UrlMap' [(prefix, Application' $ toApplication thing)]
59+mount' prefix thing = UrlMap' [(prefix, toApplication thing)]
60
60
61-- | A convenience function like mount', but for mounting things under a single
61-- | A convenience function like mount', but for mounting things under a single
62-- path segment.
62-- path segment.
@@ -78,15 +78,15 @@ try xs tuples = foldl go Nothing tuples
78 go _ (prefix, y) = stripPrefix prefix xs >>= \xs' -> return (xs', y)
78 go _ (prefix, y) = stripPrefix prefix xs >>= \xs' -> return (xs', y)
79
79
80class ToApplication a where
80class ToApplication a where
81− toApplication :: a -> Application'
81+ toApplication :: a -> Application
82
82
83instance ToApplication Application where
83instance ToApplication Application where
84− toApplication = Application'
84+ toApplication = id
85
85
86instance ToApplication UrlMap where
86instance ToApplication UrlMap where
87− toApplication urlMap req sendResponse = Application' $
87+ toApplication urlMap req sendResponse =
88 case try (pathInfo req) (unUrlMap urlMap) of
88 case try (pathInfo req) (unUrlMap urlMap) of
89− Just (newPath, Application' app) ->
89+ Just (newPath, app) ->
90 app (req { pathInfo = newPath
90 app (req { pathInfo = newPath
91 , rawPathInfo = makeRaw newPath
91 , rawPathInfo = makeRaw newPath
92 }) sendResponse
92 }) sendResponse
@@ -101,6 +101,4 @@ instance ToApplication UrlMap where
101 makeRaw = ("/" `B.append`) . T.encodeUtf8 . T.intercalate "/"
101 makeRaw = ("/" `B.append`) . T.encodeUtf8 . T.intercalate "/"
102
102
103mapUrls :: UrlMap -> Application
103mapUrls :: UrlMap -> Application
104−mapUrls um =
105− case toApplication um of
104+mapUrls = toApplication
106− Application' a -> a
wai-extra/wai-extra.cabal+1
@@ -44,6 +44,7 @@ Library
44 , word8
44 , word8
45 , lifted-base >= 0.1.2
45 , lifted-base >= 0.1.2
46 , deepseq
46 , deepseq
47+ , streaming-commons
47
48
48 if os(windows)
49 if os(windows)
49 cpp-options: -DWINDOWS
50 cpp-options: -DWINDOWS