@@ -15,8 +15,11 @@ import Data.IORef
1515import Data.Monoid (mappend)
1616import Control.Concurrent (forkIO, threadDelay)
1717import Control.Monad.IO.Class (liftIO)
18+import Control.Monad (unless)
19+import Control.Exception (throwIO)
20+import Data.Function (fix)
1821import qualified Data.ByteString as S
19−import Blaze.ByteString.Builder (fromByteString, Builder)
22+import Blaze.ByteString.Builder (fromByteString, Builder, flush)
2023import qualified Blaze.ByteString.Builder as Blaze
2124#if WINDOWS
2225import Foreign
@@ -25,6 +28,7 @@ import Foreign.C.String
2528import System.Process (rawSystem)
2629#endif
2730import Data.Streaming.Blaze (newBlazeRecv, defaultStrategy)
31+import qualified Data.Streaming.Zlib as Z
2832
2933ping :: IORef Bool -> Middleware
3034ping var app req sendResponse
@@ -41,29 +45,40 @@ ping var app req sendResponse
4145 let (s, hs, withBody) = responseToStream res
4246 (isEnc, headers') = fixHeaders id hs
4347 headers'' = filter (\(x, _) -> x /= "content-length") headers'
44− {-
45− let fixEnc src =
46− if isEnc then
47− src $= decompressFlush (WindowBits 31)
48− else src
49− -}
5048 withBody $ \body ->
5149 sendResponse $ responseStream s headers'' $ \sendChunk flush ->
52− addInsideHead sendChunk flush $ \sendChunk' flush' -> do
53− (sendChunk'', flush'') <-
54− if isEnc
55− then decode sendChunk' flush'
56− else return (sendChunk', flush')
57− body sendChunk' flush'
58− {-
59− f -> withBody $ \body -> f
60− $ fixEnc (body $= builderToByteStringFlush)
61− $= insideHead
62− $= CL.map (fmap fromByteString)
63− -}
50+ addInsideHead sendChunk flush $ \sendChunk' flush' ->
51+ if isEnc
52+ then decode sendChunk' flush' body
53+ else body sendChunk' flush'
6454 else sendResponse res
6555
66−decode = error "decode"
56+decode :: (Builder -> IO ()) -> IO ()
57+ -> StreamingBody
58+ -> IO ()
59+decode sendInner flushInner streamingBody = do
60+ (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy
61+ inflate <- Z.initInflate $ Z.WindowBits 31
62+ let send builder = blazeRecv builder >>= goBuilderPopper
63+ goBuilderPopper popper = fix $ \loop -> do
64+ bs <- popper
65+ unless (S.null bs) $ do
66+ Z.feedInflate inflate bs >>= goZlibPopper
67+ loop
68+ goZlibPopper popper = fix $ \loop -> do
69+ res <- popper
70+ case res of
71+ Z.PRDone -> return ()
72+ Z.PRNext bs -> do
73+ sendInner $ fromByteString bs
74+ loop
75+ Z.PRError e -> throwIO e
76+ streamingBody send (send flush)
77+ mbs <- blazeFinish
78+ case mbs of
79+ Nothing -> return ()
80+ Just bs -> Z.feedInflate inflate bs >>= goZlibPopper
81+ Z.finishInflate inflate >>= sendInner . fromByteString
6782
6883toInsert :: S.ByteString
6984toInsert = "<script>setInterval(function(){var x;if(window.XMLHttpRequest){x=new XMLHttpRequest();}else{x=new ActiveXObject(\"Microsoft.XMLHTTP\");}x.open(\"GET\",\"/_ping\",false);x.send();},60000)</script>"