@@ -0,0 +1,148 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE ForeignFunctionInterface #-}
3+{-# LANGUAGE CPP #-}
4+module Network.Wai.Handler.Launch (run) where
5+
6+import Network.Wai
7+import Network.HTTP.Types
8+import qualified Network.Wai.Handler.Warp as Warp
9+import Data.IORef
10+import Control.Concurrent
11+import Foreign
12+import Foreign.C.String
13+import Control.Monad.IO.Class (liftIO)
14+import qualified Data.ByteString as S
15+import Data.Enumerator (($$), enumList, joinI, Enumeratee, Stream (..), Iteratee (..), Step (..))
16+import Blaze.ByteString.Builder (fromByteString)
17+#if !WINDOWS
18+import System.Cmd (rawSystem)
19+#endif
20+import Codec.Zlib.Enum (ungzip)
21+import Blaze.ByteString.Builder.Enumerator (builderToByteString)
22+import qualified Data.Enumerator.List as EL
23+import Control.Monad.Trans.Class (lift)
24+
25+ping :: IORef Bool -> Middleware
26+ping var app req
27+ | pathInfo req == ["_ping"] = do
28+ liftIO $ writeIORef var True
29+ return $ responseLBS status200 [] ""
30+ | otherwise = do
31+ res <- app req
32+ let isHtml hs =
33+ case lookup "content-type" hs of
34+ Just ct -> "text/html" `S.isPrefixOf` ct
35+ Nothing -> False
36+ case res of
37+ ResponseFile _ hs _ _
38+ | not $ isHtml hs -> return res
39+ ResponseBuilder _ hs _
40+ | not $ isHtml hs -> return res
41+ _ -> do
42+ let renum = responseEnumerator res
43+ return $ ResponseEnumerator $ \f -> renum $ \status headers ->
44+ if isHtml headers
45+ then do
46+ let (isEnc, headers') = fixHeaders id headers
47+ let headers'' = filter (\(x, _) -> x /= "content-length") headers'
48+ let fixEnc x =
49+ if isEnc
50+ then joinI $ ungzip $$ x
51+ else x
52+ joinI $ builderToByteString $$ fixEnc $ joinI $ insideHead "<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>" $$ joinI $ EL.map fromByteString $$ f status headers''
53+ else f status headers
54+
55+insideHead :: S.ByteString -> Enumeratee S.ByteString S.ByteString IO a
56+insideHead toInsert =
57+ go "" whole
58+ where
59+ whole = "<head>"
60+ go :: S.ByteString -> S.ByteString -> Step S.ByteString IO a -> Iteratee S.ByteString IO (Step S.ByteString IO a)
61+ go held atFront step = do
62+ mx <- EL.head
63+ case mx of
64+ Nothing -> feedDone $ Chunks [held, toInsert]
65+ Just x
66+ | atFront `S.isPrefixOf` x -> do
67+ let y = S.drop (S.length atFront) x
68+ let stream = Chunks [held, atFront, toInsert, y]
69+ feedDone stream
70+ | whole `S.isInfixOf` x -> do
71+ let (before, rest) = S.breakSubstring whole x
72+ let after = S.drop (S.length whole) rest
73+ feedDone $ Chunks [held, before, whole, toInsert, after]
74+ | x `S.isPrefixOf` atFront -> go
75+ (held `S.append` x)
76+ (S.drop (S.length x) atFront)
77+ step
78+ | otherwise -> do
79+ let (held', atFront', x') = getOverlap whole x
80+ feedCont held' atFront' $ Chunks [held, x']
81+ where
82+ --feedDone :: Stream S.ByteString -> Iteratee S.ByteString IO (Step S.ByteString IO a)
83+ feedDone stream =
84+ case step of
85+ Continue k -> do
86+ step' <- lift $ runIteratee $ k stream
87+ EL.map id step'
88+ Yield b s -> return $ Yield b s
89+ Error e -> return $ Error e
90+
91+ --feedCont :: Monad m => S.ByteString -> S.ByteString -> Stream S.ByteString -> Iteratee S.ByteString m (Step S.ByteString m a)
92+ feedCont held atFront stream = do
93+ case step of
94+ Continue k -> do
95+ step' <- lift $ runIteratee $ k stream
96+ go held atFront step'
97+ Yield b s -> return $ Yield b s
98+ Error e -> return $ Error e
99+
100+getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)
101+getOverlap whole x =
102+ go whole
103+ where
104+ go piece
105+ | S.null piece = ("", whole, x)
106+ | piece `S.isSuffixOf` x =
107+ let x' = S.take (S.length x - S.length piece) x
108+ atFront = S.drop (S.length piece) whole
109+ in (piece, atFront, x')
110+ | otherwise = go $ S.init piece
111+
112+fixHeaders front [] = (False, front [])
113+fixHeaders front (("content-encoding", "gzip"):rest) = (True, front rest)
114+fixHeaders front (x:xs) = fixHeaders (front . (:) x) xs
115+
116+#if WINDOWS
117+foreign import ccall "launch"
118+ launch :: IO ()
119+#else
120+launch :: IO ()
121+launch = forkIO (rawSystem
122+#if MAC
123+ "open"
124+#else
125+ "xdg-open"
126+#endif
127+ ["http://127.0.0.1:4587/"] >> return ()) >> return ()
128+#endif
129+
130+run :: Application -> IO ()
131+run app = do
132+ x <- newIORef True
133+ forkIO $ Warp.runSettings Warp.defaultSettings
134+ { Warp.settingsPort = 4587
135+ , Warp.settingsOnException = const $ return ()
136+ , Warp.settingsHost = "127.0.0.1"
137+ } $ ping x app
138+ launch
139+ loop x
140+
141+loop :: IORef Bool -> IO ()
142+loop x = do
143+ let seconds = 120
144+ threadDelay $ 1000000 * seconds
145+ b <- readIORef x
146+ if b
147+ then writeIORef x False >> loop x
148+ else return ()