@@ -1,222 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE ForeignFunctionInterface #-}
3−{-# LANGUAGE CPP #-}
4−module Network.Wai.Handler.Launch
5− ( run
6− , runUrl
7− , runUrlPort
8− , runHostPortUrl
9− ) where
10−
11−import Network.Wai
12−import Network.Wai.Internal
13−import Network.HTTP.Types
14−import qualified Network.Wai.Handler.Warp as Warp
15−import Data.IORef
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)
27−#if WINDOWS
28−import Foreign
29−import Foreign.C.String
30−#else
31−import System.Process (rawSystem)
32−#endif
33−import Data.Streaming.ByteString.Builder as B (newBuilderRecv, defaultStrategy)
34−import qualified Data.Streaming.Zlib as Z
35−
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
42− let isHtml hs =
43− case lookup "content-type" hs of
44− Just ct -> "text/html" `S.isPrefixOf` ct
45− Nothing -> False
46− if isHtml $ responseHeaders res
47− then do
48− let (s, hs, withBody) = responseToStream res
49− (isEnc, headers') = fixHeaders id hs
50− headers'' = filter (\(x, _) -> x /= "content-length") headers'
51− withBody $ \body ->
52− sendResponse $ responseStream s headers'' $ \sendChunk flush ->
53− addInsideHead sendChunk flush $ \sendChunk' flush' ->
54− if isEnc
55− then decode sendChunk' flush' body
56− else body sendChunk' flush'
57− else sendResponse res
58−
59−decode :: (Builder -> IO ()) -> IO ()
60− -> StreamingBody
61− -> 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
67− bs <- popper
68− unless (S.null bs) $ do
69− Z.feedInflate inflate bs >>= goZlibPopper
70− loop
71− goZlibPopper popper = fix $ \loop -> do
72− res <- popper
73− case res of
74− Z.PRDone -> return ()
75− Z.PRNext bs -> do
76− sendInner $ byteString bs
77− loop
78− Z.PRError e -> throwIO e
79− streamingBody send (send Builder.flush)
80− mbs <- blazeFinish
81− case mbs of
82− Nothing -> return ()
83− Just bs -> Z.feedInflate inflate bs >>= goZlibPopper
84− Z.finishInflate inflate >>= sendInner . byteString
85−
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>"
88−
89−addInsideHead :: (Builder -> IO ())
90− -> IO ()
91− -> StreamingBody
92− -> 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
98− mbs <- blazeFinish
99− held <- case mbs of
100− Nothing -> return state
101− Just bs -> push state bs
102− case state of
103− Nothing -> return ()
104− Just (held, _) -> sendInner $ byteString held `mappend` byteString toInsert
105− where
106− whole = "<head>"
107−
108− flush blazeRecv ref = inner blazeRecv ref Builder.flush
109−
110− inner blazeRecv ref builder = do
111− state0 <- readIORef ref
112− popper <- blazeRecv builder
113− let loop state = do
114− bs <- popper
115− if S.null bs
116− then writeIORef ref state
117− else push state bs >>= loop
118− loop state0
119−
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
128− return Nothing
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
137− return Nothing
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')
142− | otherwise = do
143− let (held', atFront', x') = getOverlap whole x
144− sendInner $ byteString held `mappend` byteString x'
145− return $ Just (held', atFront')
146−
147−getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)
148−getOverlap whole x =
149− go whole
150− where
151− go piece
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
158−
159−fixHeaders :: ([Header] -> [Header])
160− -> [Header]
161− -> (Bool, [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
165−
166−#if WINDOWS
167−foreign import ccall "launch"
168− launch' :: Int -> CString -> IO ()
169−#endif
170−
171−launch :: Int -> String -> IO ()
172−
173−#if WINDOWS
174−launch port s = withCString s $ launch' port
175−#else
176−launch port s = forkIO (rawSystem
177−#if MAC
178− "open"
179−#else
180− "xdg-open"
181−#endif
182− ["http://127.0.0.1:" ++ show port ++ "/" ++ s] >> return ()) >> return ()
183−#endif
184−
185−run :: Application -> IO ()
186−run = runUrl ""
187−
188−runUrl :: String -> Application -> IO ()
189−runUrl = runUrlPort 4587
190−
191−runUrlPort :: Int -> String -> Application -> IO ()
192−runUrlPort = runHostPortUrl "*4"
193−
194−-- |
195−--
196−-- @since 3.0.1
197−runHostPortUrl :: String -> Int -> String -> Application -> IO ()
198−runHostPortUrl host port url app = do
199− ready <- newEmptyMVar
200− active <- newIORef True
201− let settings =
202− Warp.setPort port $
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)
214−
215−loop :: IORef Bool -> IO ()
216−loop active = do
217− let seconds = 120
218− threadDelay $ 1000000 * seconds
219− b <- readIORef active
220− if b
221− then writeIORef active False >> loop active
222− else return ()