git.iko.soy/typeable/wai
on master help sign in
xmltest
1797b3eMichael Snoyman
Network/Wai/Handler/Helper.hs+13−8
compare with master
unifiedsplit
@@ -6,20 +6,25 @@ module Network.Wai.Handler.Helper
6import System.IO (Handle)
6import System.IO (Handle)
7import qualified Data.ByteString as B
7import qualified Data.ByteString as B
8import Data.ByteString.Lazy.Internal (defaultChunkSize)
8import 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)
10
12
11−requestBodyHandle :: Handle -> Int -> Source
13+requestBodyHandle :: Handle -> Int -> E.Enumerator B.ByteString IO a
12requestBodyHandle h =
14requestBodyHandle h =
13 requestBodyFunc go
15 requestBodyFunc go
14 where
16 where
15 go i = Just `fmap` B.hGet h (min i defaultChunkSize)
17 go i = Just `fmap` B.hGet h (min i defaultChunkSize)
16
18
17−requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source
19+requestBodyFunc :: (Int -> IO (Maybe B.ByteString))
20+ -> Int
21+ -> E.Enumerator B.ByteString IO a
18−requestBodyFunc _ 0 = Source $ return Nothing
22+requestBodyFunc _ 0 step = E.returnI step
19−requestBodyFunc h len = Source $ do
23+requestBodyFunc h len (E.Continue k) = do
20− mbs <- h len
24+ mbs <- liftIO $ h len
21 case mbs of
25 case mbs of
22− Nothing -> return Nothing
26+ Nothing -> E.continue k
23 Just bs -> do
27 Just bs -> do
24 let newLen = len - B.length bs
28 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)
41import Control.Arrow (first)
41import Control.Arrow (first)
42import Numeric (showHex)
42import Numeric (showHex)
43
43
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+
44run :: Port -> Application -> IO ()
50run :: Port -> Application -> IO ()
45run port = withSocketsDo .
51run port = withSocketsDo .
46 bracket
52 bracket
@@ -158,15 +164,17 @@ sendResponse httpversion h res = do
158 mapM_ putHeader $ responseHeaders res
164 mapM_ putHeader $ responseHeaders res
159 B.hPut h $ B.pack "Transfer-Encoding: chunked\r\n\r\n"
165 B.hPut h $ B.pack "Transfer-Encoding: chunked\r\n\r\n"
160 case responseBody res of
166 case responseBody res of
161− ResponseFile fp -> do
167+ ResponseFile fp -> E.run_ $ enumFile fp $$ myIter
162− -- FIXME this is lazy I/O
163− lbs <- L.readFile fp
164− mapM_ myPut $ L.toChunks lbs
165− ResponseEnumerator (Enumerator enum) ->
168+ ResponseEnumerator enum ->
166− enum (const myPut) h >> return ()
169+ enum $ E.joinI $ builderToByteString $$ myIter
167 ResponseLBS lbs -> mapM_ myPut $ L.toChunks lbs
170 ResponseLBS lbs -> mapM_ myPut $ L.toChunks lbs
168 B.hPut h $ B.pack "0\r\n\r\n"
171 B.hPut h $ B.pack "0\r\n\r\n"
169 where
172 where
173+ myIter = do
174+ mbs <- E.head
175+ case mbs of
176+ Nothing -> return ()
177+ Just bs -> liftIO (myPut bs) >> myIter
170 myPut bs = do
178 myPut bs = do
171 B.hPut h $ B.pack $ showHex (B.length bs) " \r\n"
179 B.hPut h $ B.pack $ showHex (B.length bs) " \r\n"
172 B.hPut h bs
180 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