diff --git a/Network/Wai/Handler/Launch.hs b/Network/Wai/Handler/Launch.hs --- a/Network/Wai/Handler/Launch.hs +++ b/Network/Wai/Handler/Launch.hs @@ -12,84 +12,134 @@ import Network.HTTP.Types import qualified Network.Wai.Handler.Warp as Warp import Data.IORef +import Data.Monoid (mappend) import Control.Concurrent (forkIO, threadDelay) import Control.Monad.IO.Class (liftIO) +import Control.Monad (unless) +import Control.Exception (throwIO) +import Data.Function (fix) import qualified Data.ByteString as S -import Blaze.ByteString.Builder (fromByteString) +import Blaze.ByteString.Builder (fromByteString, Builder, flush) +import qualified Blaze.ByteString.Builder as Blaze #if WINDOWS import Foreign import Foreign.C.String #else -import System.Cmd (rawSystem) +import System.Process (rawSystem) #endif -import Data.Conduit.Zlib (decompressFlush, WindowBits (WindowBits)) -import Data.Conduit.Blaze (builderToByteStringFlush) -import Data.Conduit -import qualified Data.Conduit.List as CL +import Data.Streaming.Blaze (newBlazeRecv, defaultStrategy) +import qualified Data.Streaming.Zlib as Z ping :: IORef Bool -> Middleware -ping var app req +ping var app req sendResponse | pathInfo req == ["_ping"] = do liftIO $ writeIORef var True - return $ responseLBS status200 [] "" - | otherwise = do - res <- app req + sendResponse $ responseLBS status200 [] "" + | otherwise = app req $ \res -> do let isHtml hs = case lookup "content-type" hs of Just ct -> "text/html" `S.isPrefixOf` ct Nothing -> False - case res of - ResponseFile _ hs _ _ - | not $ isHtml hs -> return res - ResponseBuilder _ hs _ - | not $ isHtml hs -> return res - ResponseSource _ hs _ - | not $ isHtml hs -> return res - _ -> do - let (s, hs, withBody) = responseToSource res - let (isEnc, headers') = fixHeaders id hs - let headers'' = filter (\(x, _) -> x /= "content-length") headers' - let fixEnc src = - if isEnc then - src $= decompressFlush (WindowBits 31) - else src - return $ ResponseSource s headers'' $ \f -> withBody $ \body -> f - $ fixEnc (body $= builderToByteStringFlush) - $= insideHead - $= CL.map (fmap fromByteString) + if isHtml $ responseHeaders res + then do + let (s, hs, withBody) = responseToStream res + (isEnc, headers') = fixHeaders id hs + headers'' = filter (\(x, _) -> x /= "content-length") headers' + withBody $ \body -> + sendResponse $ responseStream s headers'' $ \sendChunk flush -> + addInsideHead sendChunk flush $ \sendChunk' flush' -> + if isEnc + then decode sendChunk' flush' body + else body sendChunk' flush' + else sendResponse res +decode :: (Builder -> IO ()) -> IO () + -> StreamingBody + -> IO () +decode sendInner flushInner streamingBody = do + (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy + inflate <- Z.initInflate $ Z.WindowBits 31 + let send builder = blazeRecv builder >>= goBuilderPopper + goBuilderPopper popper = fix $ \loop -> do + bs <- popper + unless (S.null bs) $ do + Z.feedInflate inflate bs >>= goZlibPopper + loop + goZlibPopper popper = fix $ \loop -> do + res <- popper + case res of + Z.PRDone -> return () + Z.PRNext bs -> do + sendInner $ fromByteString bs + loop + Z.PRError e -> throwIO e + streamingBody send (send flush) + mbs <- blazeFinish + case mbs of + Nothing -> return () + Just bs -> Z.feedInflate inflate bs >>= goZlibPopper + Z.finishInflate inflate >>= sendInner . fromByteString + toInsert :: S.ByteString toInsert = "" -insideHead :: Conduit (Flush S.ByteString) IO (Flush S.ByteString) -insideHead = - loop' (S.empty, whole) +addInsideHead :: (Builder -> IO ()) + -> IO () + -> StreamingBody + -> IO () +addInsideHead sendInner flushInner streamingBody = do + (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy + ref <- newIORef $ Just (S.empty, whole) + streamingBody (inner blazeRecv ref) (flush blazeRecv ref) + state <- readIORef ref + mbs <- blazeFinish + held <- case mbs of + Nothing -> return state + Just bs -> push state bs + case state of + Nothing -> return () + Just (held, _) -> sendInner $ fromByteString held `mappend` fromByteString toInsert where - loop' state = await >>= maybe (close state) (push' state) whole = "" - push' state (Chunk x) = push state x - push' state Flush = yield Flush >> loop' state - push (held, atFront) x + flush blazeRecv ref = inner blazeRecv ref Blaze.flush + + inner blazeRecv ref builder = do + state0 <- readIORef ref + popper <- blazeRecv builder + let loop state = do + bs <- popper + if S.null bs + then writeIORef ref state + else push state bs >>= loop + loop state0 + + push Nothing x = sendInner (fromByteString x) >> return Nothing + push (Just (held, atFront)) x | atFront `S.isPrefixOf` x = do let y = S.drop (S.length atFront) x - mapM_ (yield . Chunk) [held, atFront, toInsert, y] - CL.map id + sendInner $ fromByteString held + `mappend` fromByteString atFront + `mappend` fromByteString toInsert + `mappend` fromByteString y + return Nothing | whole `S.isInfixOf` x = do let (before, rest) = S.breakSubstring whole x let after = S.drop (S.length whole) rest - mapM_ (yield . Chunk) [held, before, whole, toInsert, after] - CL.map id + sendInner $ fromByteString held + `mappend` fromByteString before + `mappend` fromByteString whole + `mappend` fromByteString toInsert + `mappend` fromByteString after + return Nothing | x `S.isPrefixOf` atFront = do let held' = held `S.append` x atFront' = S.drop (S.length x) atFront - loop' (held', atFront') + return $ Just (held', atFront') | otherwise = do let (held', atFront', x') = getOverlap whole x - mapM_ (yield . Chunk) [held, x'] - loop' (held', atFront') - - close (held, _) = mapM_ yield [Chunk held, Chunk toInsert] + sendInner $ fromByteString held `mappend` fromByteString x' + return $ Just (held', atFront') getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString) getOverlap whole x = @@ -138,11 +188,11 @@ runUrlPort :: Int -> String -> Application -> IO () runUrlPort port url app = do x <- newIORef True - _ <- forkIO $ Warp.runSettings Warp.defaultSettings - { Warp.settingsPort = port - , Warp.settingsOnException = (\_ _ -> return ()) - , Warp.settingsHost = "*4" - } $ ping x app + _ <- forkIO $ Warp.runSettings + ( Warp.setPort port + $ Warp.setOnException (\_ _ -> return ()) + $ Warp.setHost "*4" Warp.defaultSettings) + $ ping x app launch port url loop x diff --git a/wai-handler-launch.cabal b/wai-handler-launch.cabal --- a/wai-handler-launch.cabal +++ b/wai-handler-launch.cabal @@ -1,5 +1,5 @@ Name: wai-handler-launch -Version: 2.0.1.3 +Version: 3.0.0 Synopsis: Launch a web app in the default browser. Description: This handles cross-platform launching and inserts Javascript code to ping the server. When the server no longer receives pings, it shuts down. License: MIT @@ -13,16 +13,13 @@ Library Exposed-modules: Network.Wai.Handler.Launch build-depends: base >= 4 && < 5 - , wai >= 2.0 && < 2.2 - , warp >= 2.0 && < 2.2 + , wai >= 3.0 && < 3.1 + , warp >= 3.0 && < 3.1 , http-types >= 0.7 , transformers >= 0.2.2 , bytestring >= 0.9.1.4 , blaze-builder >= 0.2.1.4 && < 0.4 - , conduit >= 0.5 && < 1.2 - , conduit-extra >= 0.0 && < 1.2 - , blaze-builder-conduit >= 0.5 && < 1.2 - , zlib-conduit >= 0.5 && < 1.2 + , streaming-commons if os(windows) c-sources: windows.c