@@ -1,222 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE ForeignFunctionInterface #-}
4−module Network.Wai.Handler.Launch
12−import Network.Wai.Internal
13−import Network.HTTP.Types
14−import qualified Network.Wai.Handler.Warp as Warp
16−import Data.Monoid (mappend)
17−import Data.String (fromString)
18−import Control.Concurrent (forkIO, threadDelay, newEmptyMVar, putMVar, takeMVar)
19−import Control.Concurrent.Async (race)
20−import Control.Monad.IO.Class (liftIO)
21−import Control.Monad (unless)
22−import Control.Exception (throwIO)
23−import Data.Function (fix)
24−import qualified Data.ByteString as S
25−import Data.ByteString.Builder (Builder, byteString)
26−import qualified Data.ByteString.Builder.Extra as Builder (flush)
29−import Foreign.C.String
31−import System.Process (rawSystem)
33−import Data.Streaming.ByteString.Builder as B (newBuilderRecv, defaultStrategy)
34−import qualified Data.Streaming.Zlib as Z
36−ping :: IORef Bool -> Middleware
37−ping active app req sendResponse
38− | pathInfo req == ["_ping"] = do
39− liftIO $ writeIORef active True
40− sendResponse $ responseLBS status200 [] ""
41− | otherwise = app req $ \res -> do
43− case lookup "content-type" hs of
44− Just ct -> "text/html" `S.isPrefixOf` ct
46− if isHtml $ responseHeaders res
48− let (s, hs, withBody) = responseToStream res
49− (isEnc, headers') = fixHeaders id hs
50− headers'' = filter (\(x, _) -> x /= "content-length") headers'
52− sendResponse $ responseStream s headers'' $ \sendChunk flush ->
53− addInsideHead sendChunk flush $ \sendChunk' flush' ->
55− then decode sendChunk' flush' body
56− else body sendChunk' flush'
57− else sendResponse res
59−decode :: (Builder -> IO ()) -> IO ()
62−decode sendInner flushInner streamingBody = do
63− (blazeRecv, blazeFinish) <- newBuilderRecv defaultStrategy
64− inflate <- Z.initInflate $ Z.WindowBits 31
65− let send builder = blazeRecv builder >>= goBuilderPopper
66− goBuilderPopper popper = fix $ \loop -> do
68− unless (S.null bs) $ do
69− Z.feedInflate inflate bs >>= goZlibPopper
71− goZlibPopper popper = fix $ \loop -> do
74− Z.PRDone -> return ()
76− sendInner $ byteString bs
78− Z.PRError e -> throwIO e
79− streamingBody send (send Builder.flush)
83− Just bs -> Z.feedInflate inflate bs >>= goZlibPopper
84− Z.finishInflate inflate >>= sendInner . byteString
86−toInsert :: S.ByteString
87−toInsert = "<script>setInterval(function(){var x;if(window.XMLHttpRequest){x=new XMLHttpRequest();}else{x=new ActiveXObject(\"Microsoft.XMLHTTP\");}x.open(\"GET\",\"/_ping?\" + (new Date()).getTime(),true);x.send();},60000)</script>"
89−addInsideHead :: (Builder -> IO ())
93−addInsideHead sendInner flushInner streamingBody = do
94− (blazeRecv, blazeFinish) <- newBuilderRecv defaultStrategy
95− ref <- newIORef $ Just (S.empty, whole)
96− streamingBody (inner blazeRecv ref) (flush blazeRecv ref)
97− state <- readIORef ref
100− Nothing -> return state
101− Just bs -> push state bs
103− Nothing -> return ()
104− Just (held, _) -> sendInner $ byteString held `mappend` byteString toInsert
108− flush blazeRecv ref = inner blazeRecv ref Builder.flush
110− inner blazeRecv ref builder = do
111− state0 <- readIORef ref
112− popper <- blazeRecv builder
116− then writeIORef ref state
117− else push state bs >>= loop
120− push Nothing x = sendInner (byteString x) >> return Nothing
121− push (Just (held, atFront)) x
122− | atFront `S.isPrefixOf` x = do
123− let y = S.drop (S.length atFront) x
124− sendInner $ byteString held
125− `mappend` byteString atFront
126− `mappend` byteString toInsert
127− `mappend` byteString y
129− | whole `S.isInfixOf` x = do
130− let (before, rest) = S.breakSubstring whole x
131− let after = S.drop (S.length whole) rest
132− sendInner $ byteString held
133− `mappend` byteString before
134− `mappend` byteString whole
135− `mappend` byteString toInsert
136− `mappend` byteString after
138− | x `S.isPrefixOf` atFront = do
139− let held' = held `S.append` x
140− atFront' = S.drop (S.length x) atFront
141− return $ Just (held', atFront')
143− let (held', atFront', x') = getOverlap whole x
144− sendInner $ byteString held `mappend` byteString x'
145− return $ Just (held', atFront')
147−getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)
152− | S.null piece = ("", whole, x)
153− | piece `S.isSuffixOf` x =
154− let x' = S.take (S.length x - S.length piece) x
155− atFront = S.drop (S.length piece) whole
156− in (piece, atFront, x')
157− | otherwise = go $ S.init piece
159−fixHeaders :: ([Header] -> [Header])
162−fixHeaders front [] = (False, front [])
163−fixHeaders front (("content-encoding", "gzip"):rest) = (True, front rest)
164−fixHeaders front (x:xs) = fixHeaders (front . (:) x) xs
167−foreign import ccall "launch"
168− launch' :: Int -> CString -> IO ()
171−launch :: Int -> String -> IO ()
174−launch port s = withCString s $ launch' port
176−launch port s = forkIO (rawSystem
182− ["http://127.0.0.1:" ++ show port ++ "/" ++ s] >> return ()) >> return ()
185−run :: Application -> IO ()
188−runUrl :: String -> Application -> IO ()
189−runUrl = runUrlPort 4587
191−runUrlPort :: Int -> String -> Application -> IO ()
192−runUrlPort = runHostPortUrl "*4"
197−runHostPortUrl :: String -> Int -> String -> Application -> IO ()
198−runHostPortUrl host port url app = do
199− ready <- newEmptyMVar
200− active <- newIORef True
203− Warp.setOnException (\_ _ -> return ()) $
204− Warp.setHost (fromString host) $
205− Warp.setBeforeMainLoop (putMVar ready ()) $
206− Warp.defaultSettings
207− -- Run these threads concurrently; when either one terminates or
208− -- raises an exception, the same happens to the other.
209− fmap (either id id) $ race
210− -- serve app, keep updating the activity flag
211− (Warp.runSettings settings (ping active app))
212− -- wait for server startup, launch browser, poll until server idle
213− (takeMVar ready >> launch port url >> loop active)
215−loop :: IORef Bool -> IO ()
218− threadDelay $ 1000000 * seconds
219− b <- readIORef active
221− then writeIORef active False >> loop active