800577c · typeable/wai

12import Network.HTTP.Types

13import qualified Network.Wai.Handler.Warp as Warp

14import Data.IORef

15+import Data.Monoid (mappend)

15import Control.Concurrent (forkIO, threadDelay)

16import Control.Concurrent (forkIO, threadDelay)

16import Control.Monad.IO.Class (liftIO)

17import Control.Monad.IO.Class (liftIO)

17import qualified Data.ByteString as S

18import 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

19#if WINDOWS

21#if WINDOWS

20import Foreign

22import Foreign

21import Foreign.C.String

23import Foreign.C.String

22#else

24#else

23−import System.Cmd (rawSystem)

25+import System.Process (rawSystem)

24#endif

26#endif

25−import Data.Conduit.Zlib (decompressFlush, WindowBits (WindowBits))

27+import Data.Streaming.Blaze (newBlazeRecv, defaultStrategy)

26−import Data.Conduit.Blaze (builderToByteStringFlush)

27−import Data.Conduit

28−import qualified Data.Conduit.List as CL

29

28

30ping :: IORef Bool -> Middleware

29ping :: IORef Bool -> Middleware

31−ping var app req

30+ping var app req sendResponse

32 | pathInfo req == ["_ping"] = do

31 | pathInfo req == ["_ping"] = do

33 liftIO $ writeIORef var True

32 liftIO $ writeIORef var True

34− return $ responseLBS status200 [] ""

33+ sendResponse $ responseLBS status200 [] ""

35− | otherwise = do

34+ | otherwise = app req $ \res -> do

36− res <- app req

37 let isHtml hs =

35 let isHtml hs =

38 case lookup "content-type" hs of

36 case lookup "content-type" hs of

39 Just ct -> "text/html" `S.isPrefixOf` ct

37 Just ct -> "text/html" `S.isPrefixOf` ct

40 Nothing -> False

38 Nothing -> False

41− case res of

39+ if isHtml $ responseHeaders res

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

40+ then do

49− let (s, hs, withBody) = responseToSource res

41+ let (s, hs, withBody) = responseToStream res

50− let (isEnc, headers') = fixHeaders id hs

42+ (isEnc, headers') = fixHeaders id hs

51− let headers'' = filter (\(x, _) -> x /= "content-length") headers'

43+ headers'' = filter (\(x, _) -> x /= "content-length") headers'

44+ {-

52 let fixEnc src =

45 let fixEnc src =

53 if isEnc then

46 if isEnc then

54 src $= decompressFlush (WindowBits 31)

47 src $= decompressFlush (WindowBits 31)

55 else src

48 else src

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+ {-

56− return $ ResponseSource s headers'' $ \f -> withBody $ \body -> f

59+ f -> withBody $ \body -> f

57− $ fixEnc (body $= builderToByteStringFlush)

60+ $ fixEnc (body $= builderToByteStringFlush)

58− $= insideHead

61+ $= insideHead

59− $= CL.map (fmap fromByteString)

62+ $= CL.map (fmap fromByteString)

63+ -}

64+ else sendResponse res

65+

66+decode = error "decode"

60

67

61toInsert :: S.ByteString

68toInsert :: S.ByteString

62toInsert = "<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>"

69toInsert = "<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>"

63

70

64−insideHead :: Conduit (Flush S.ByteString) IO (Flush S.ByteString)

71+addInsideHead :: (Builder -> IO ())

65−insideHead =

72+ -> IO ()

73+ -> StreamingBody

74+ -> IO ()

75+addInsideHead sendInner flushInner streamingBody = do

76+ (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy

66− loop' (S.empty, whole)

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

67 where

87 where

68− loop' state = await >>= maybe (close state) (push' state)

69 whole = "<head>"

88 whole = "<head>"

70− push' state (Chunk x) = push state x

71− push' state Flush = yield Flush >> loop' state

72

89

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

73− push (held, atFront) x

103+ push (Just (held, atFront)) x

74 | atFront `S.isPrefixOf` x = do

104 | atFront `S.isPrefixOf` x = do

75 let y = S.drop (S.length atFront) x

105 let y = S.drop (S.length atFront) x

76− mapM_ (yield . Chunk) [held, atFront, toInsert, y]

106+ sendInner $ fromByteString held

77− CL.map id

107+ `mappend` fromByteString atFront

108+ `mappend` fromByteString toInsert

109+ `mappend` fromByteString y

110+ return Nothing

78 | whole `S.isInfixOf` x = do

111 | whole `S.isInfixOf` x = do

79 let (before, rest) = S.breakSubstring whole x

112 let (before, rest) = S.breakSubstring whole x

80 let after = S.drop (S.length whole) rest

113 let after = S.drop (S.length whole) rest

81− mapM_ (yield . Chunk) [held, before, whole, toInsert, after]

114+ sendInner $ fromByteString held

82− CL.map id

115+ `mappend` fromByteString before

116+ `mappend` fromByteString whole

117+ `mappend` fromByteString toInsert

118+ `mappend` fromByteString after

119+ return Nothing

83 | x `S.isPrefixOf` atFront = do

120 | x `S.isPrefixOf` atFront = do

84 let held' = held `S.append` x

121 let held' = held `S.append` x

85 atFront' = S.drop (S.length x) atFront

122 atFront' = S.drop (S.length x) atFront

86− loop' (held', atFront')

123+ return $ Just (held', atFront')

87 | otherwise = do

124 | otherwise = do

88 let (held', atFront', x') = getOverlap whole x

125 let (held', atFront', x') = getOverlap whole x

89− mapM_ (yield . Chunk) [held, x']

126+ sendInner $ fromByteString held `mappend` fromByteString x'

90− loop' (held', atFront')

127+ return $ Just (held', atFront')

91−

92− close (held, _) = mapM_ yield [Chunk held, Chunk toInsert]

93

128

94getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)

129getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)

95getOverlap whole x =

130getOverlap whole x =

138runUrlPort :: Int -> String -> Application -> IO ()

173runUrlPort :: Int -> String -> Application -> IO ()

139runUrlPort port url app = do

174runUrlPort port url app = do

140 x <- newIORef True

175 x <- newIORef True

141− _ <- forkIO $ Warp.runSettings Warp.defaultSettings

176+ _ <- forkIO $ Warp.runSettings

142− { Warp.settingsPort = port

177+ ( Warp.setPort port

143− , Warp.settingsOnException = (\_ _ -> return ())

178+ $ Warp.setOnException (\_ _ -> return ())

144− , Warp.settingsHost = "*4"

179+ $ Warp.setHost "*4" Warp.defaultSettings)

145− } $ ping x app

180+ $ ping x app

146 launch port url

181 launch port url

147 loop x

182 loop x

148

183