git.iko.soy/typeable/wai
on master help sign in
xmltest
commit1797b3eac4bcbc48140925dc80ba9b44e0993d81 authorMichael Snoyman <michael@snoyman.com> dateTue 14 Dec 2010, 00:16 (16 years ago) parent84a1725
3 files changed+55−14
compare with master
unifiedsplit
Network/Wai/Handler/Helper.hs+13−8 Network/Wai/Handler/SimpleServer.hs+14−6 xmltest.hs+28
Network/Wai/Handler/Helper.hs+13−8
@@ -6,20 +6,25 @@ module Network.Wai.Handler.Helper
66import System.IO (Handle)
77import qualified Data.ByteString as B
88import Data.ByteString.Lazy.Internal (defaultChunkSize)
9−import Network.Wai (Source (..))
9+import qualified Data.Enumerator as E
10+import Data.Enumerator ((>>==))
11+import Control.Monad.IO.Class (liftIO)
1012
11−requestBodyHandle :: Handle -> Int -> Source
13+requestBodyHandle :: Handle -> Int -> E.Enumerator B.ByteString IO a
1214requestBodyHandle h =
1315 requestBodyFunc go
1416 where
1517 go i = Just `fmap` B.hGet h (min i defaultChunkSize)
1618
17−requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source
18−requestBodyFunc _ 0 = Source $ return Nothing
19−requestBodyFunc h len = Source $ do
20− mbs <- h len
19+requestBodyFunc :: (Int -> IO (Maybe B.ByteString))
20+ -> Int
21+ -> E.Enumerator B.ByteString IO a
22+requestBodyFunc _ 0 step = E.returnI step
23+requestBodyFunc h len (E.Continue k) = do
24+ mbs <- liftIO $ h len
2125 case mbs of
22− Nothing -> return Nothing
26+ Nothing -> E.continue k
2327 Just bs -> do
2428 let newLen = len - B.length bs
25− return $ Just (bs, requestBodyFunc h $ max 0 newLen)
29+ k (E.Chunks [bs]) >>== requestBodyFunc h newLen
30+requestBodyFunc _ _ step = E.returnI step
Network/Wai/Handler/SimpleServer.hs+14−6
@@ -41,6 +41,12 @@ import Data.Typeable (Typeable)
4141import Control.Arrow (first)
4242import Numeric (showHex)
4343
44+import Data.Enumerator (($$))
45+import qualified Data.Enumerator as E
46+import Data.Enumerator.IO (enumFile)
47+import Control.Monad.IO.Class (liftIO)
48+import Blaze.ByteString.Builder.Enumerator (builderToByteString)
49+
4450run :: Port -> Application -> IO ()
4551run port = withSocketsDo .
4652 bracket
@@ -158,15 +164,17 @@ sendResponse httpversion h res = do
158164 mapM_ putHeader $ responseHeaders res
159165 B.hPut h $ B.pack "Transfer-Encoding: chunked\r\n\r\n"
160166 case responseBody res of
161− ResponseFile fp -> do
162− -- FIXME this is lazy I/O
163− lbs <- L.readFile fp
164− mapM_ myPut $ L.toChunks lbs
165− ResponseEnumerator (Enumerator enum) ->
166− enum (const myPut) h >> return ()
167+ ResponseFile fp -> E.run_ $ enumFile fp $$ myIter
168+ ResponseEnumerator enum ->
169+ enum $ E.joinI $ builderToByteString $$ myIter
167170 ResponseLBS lbs -> mapM_ myPut $ L.toChunks lbs
168171 B.hPut h $ B.pack "0\r\n\r\n"
169172 where
173+ myIter = do
174+ mbs <- E.head
175+ case mbs of
176+ Nothing -> return ()
177+ Just bs -> liftIO (myPut bs) >> myIter
170178 myPut bs = do
171179 B.hPut h $ B.pack $ showHex (B.length bs) " \r\n"
172180 B.hPut h bs
xmltest.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+import qualified Network.HTTP.Enumerator as H
3+import qualified Network.Wai as W
4+import Network.Wai.Handler.SimpleServer (run)
5+import Data.Maybe (fromJust)
6+import qualified Data.ByteString.Char8 as S8
7+import qualified Text.XML.Enumerator.Parse as X
8+import qualified Text.XML.Enumerator.Render as X
9+import Data.Enumerator (($$), joinI, run_)
10+
11+main :: IO ()
12+main = run 3000 app
13+
14+app :: W.Application
15+app wreq = do
16+ return $ W.Response
17+ { W.status = W.status200
18+ , W.responseHeaders =
19+ [ ("Content-Type", "text/xml")
20+ ]
21+ , W.responseBody = W.ResponseEnumerator
22+ $ \step -> run_ $ H.apply2 (H.http hreq) $ const $ const
23+ $ joinI $ X.detectUtf
24+ $$ joinI $ X.parseBytes
25+ $$ joinI $ X.renderBuilder $$ step
26+ }
27+ where
28+ hreq = fromJust $ H.parseUrl $ S8.unpack $ S8.tail $ W.pathInfo wreq