@@ -12,84 +12,119 @@ import Network.Wai.Internal
1212import Network.HTTP.Types
1313import qualified Network.Wai.Handler.Warp as Warp
1414import Data.IORef
15+import Data.Monoid (mappend)
1516import Control.Concurrent (forkIO, threadDelay)
1617import Control.Monad.IO.Class (liftIO)
1718import qualified Data.ByteString as S
18−import Blaze.ByteString.Builder (fromByteString)
19+import Blaze.ByteString.Builder (fromByteString, Builder)
20+import qualified Blaze.ByteString.Builder as Blaze
1921#if WINDOWS
2022import Foreign
2123import Foreign.C.String
2224#else
23−import System.Cmd (rawSystem)
25+import System.Process (rawSystem)
2426#endif
25−import Data.Conduit.Zlib (decompressFlush, WindowBits (WindowBits))
26−import Data.Conduit.Blaze (builderToByteStringFlush)
27−import Data.Conduit
28−import qualified Data.Conduit.List as CL
27+import Data.Streaming.Blaze (newBlazeRecv, defaultStrategy)
2928
3029ping :: IORef Bool -> Middleware
31−ping var app req
30+ping var app req sendResponse
3231 | pathInfo req == ["_ping"] = do
3332 liftIO $ writeIORef var True
34− return $ responseLBS status200 [] ""
35− | otherwise = do
36− res <- app req
33+ sendResponse $ responseLBS status200 [] ""
34+ | otherwise = app req $ \res -> do
3735 let isHtml hs =
3836 case lookup "content-type" hs of
3937 Just ct -> "text/html" `S.isPrefixOf` ct
4038 Nothing -> False
41− case res of
42− ResponseFile _ hs _ _
43− | not $ isHtml hs -> return res
44− ResponseBuilder _ hs _
45− | not $ isHtml hs -> return res
46− ResponseSource _ hs _
47− | not $ isHtml hs -> return res
48− _ -> do
49− let (s, hs, withBody) = responseToSource res
50− let (isEnc, headers') = fixHeaders id hs
51− let headers'' = filter (\(x, _) -> x /= "content-length") headers'
39+ if isHtml $ responseHeaders res
40+ then do
41+ let (s, hs, withBody) = responseToStream res
42+ (isEnc, headers') = fixHeaders id hs
43+ headers'' = filter (\(x, _) -> x /= "content-length") headers'
44+ {-
5245 let fixEnc src =
5346 if isEnc then
5447 src $= decompressFlush (WindowBits 31)
5548 else src
56− return $ ResponseSource s headers'' $ \f -> withBody $ \body -> f
57− $ fixEnc (body $= builderToByteStringFlush)
58− $= insideHead
59− $= CL.map (fmap fromByteString)
49+ -}
50+ withBody $ \body ->
51+ 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+ -}
64+ else sendResponse res
65+
66+decode = error "decode"
6067
6168toInsert :: S.ByteString
6269toInsert = "<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>"
6370
64−insideHead :: Conduit (Flush S.ByteString) IO (Flush S.ByteString)
65−insideHead =
66− loop' (S.empty, whole)
71+addInsideHead :: (Builder -> IO ())
72+ -> IO ()
73+ -> StreamingBody
74+ -> IO ()
75+addInsideHead sendInner flushInner streamingBody = do
76+ (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy
77+ ref <- newIORef $ Just (S.empty, whole)
78+ streamingBody (inner blazeRecv ref) (flush blazeRecv ref)
79+ state <- readIORef ref
80+ mbs <- blazeFinish
81+ held <- case mbs of
82+ Nothing -> return state
83+ Just bs -> push state bs
84+ case state of
85+ Nothing -> return ()
86+ Just (held, _) -> sendInner $ fromByteString held `mappend` fromByteString toInsert
6787 where
68− loop' state = await >>= maybe (close state) (push' state)
6988 whole = "<head>"
70− push' state (Chunk x) = push state x
71− push' state Flush = yield Flush >> loop' state
7289
73− push (held, atFront) x
90+ flush blazeRecv ref = inner blazeRecv ref Blaze.flush
91+
92+ inner blazeRecv ref builder = do
93+ state0 <- readIORef ref
94+ popper <- blazeRecv builder
95+ let loop state = do
96+ bs <- popper
97+ if S.null bs
98+ then writeIORef ref state
99+ else push state bs >>= loop
100+ loop state0
101+
102+ push Nothing x = sendInner (fromByteString x) >> return Nothing
103+ push (Just (held, atFront)) x
74104 | atFront `S.isPrefixOf` x = do
75105 let y = S.drop (S.length atFront) x
76− mapM_ (yield . Chunk) [held, atFront, toInsert, y]
77− CL.map id
106+ sendInner $ fromByteString held
107+ `mappend` fromByteString atFront
108+ `mappend` fromByteString toInsert
109+ `mappend` fromByteString y
110+ return Nothing
78111 | whole `S.isInfixOf` x = do
79112 let (before, rest) = S.breakSubstring whole x
80113 let after = S.drop (S.length whole) rest
81− mapM_ (yield . Chunk) [held, before, whole, toInsert, after]
82− CL.map id
114+ sendInner $ fromByteString held
115+ `mappend` fromByteString before
116+ `mappend` fromByteString whole
117+ `mappend` fromByteString toInsert
118+ `mappend` fromByteString after
119+ return Nothing
83120 | x `S.isPrefixOf` atFront = do
84121 let held' = held `S.append` x
85122 atFront' = S.drop (S.length x) atFront
86− loop' (held', atFront')
123+ return $ Just (held', atFront')
87124 | otherwise = do
88125 let (held', atFront', x') = getOverlap whole x
89− mapM_ (yield . Chunk) [held, x']
90− loop' (held', atFront')
91−
92− close (held, _) = mapM_ yield [Chunk held, Chunk toInsert]
126+ sendInner $ fromByteString held `mappend` fromByteString x'
127+ return $ Just (held', atFront')
93128
94129getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)
95130getOverlap whole x =
@@ -138,11 +173,11 @@ runUrl = runUrlPort 4587
138173runUrlPort :: Int -> String -> Application -> IO ()
139174runUrlPort port url app = do
140175 x <- newIORef True
141− _ <- forkIO $ Warp.runSettings Warp.defaultSettings
142− { Warp.settingsPort = port
143− , Warp.settingsOnException = (\_ _ -> return ())
144− , Warp.settingsHost = "*4"
145− } $ ping x app
176+ _ <- forkIO $ Warp.runSettings
177+ ( Warp.setPort port
178+ $ Warp.setOnException (\_ _ -> return ())
179+ $ Warp.setHost "*4" Warp.defaultSettings)
180+ $ ping x app
146181 launch port url
147182 loop x
148183