wai-handler-launch-3.0.2.1/0000755000000000000000000000000012720233004013475 5ustar0000000000000000wai-handler-launch-3.0.2.1/ChangeLog.md0000644000000000000000000000063612720233004015653 0ustar0000000000000000## 3.0.2.1 * Relax upper bound on process ## 3.0.2 * Don't launch if server fails; kill server on exit [#537](https://github.com/yesodweb/wai/issues/537) [#541](https://github.com/yesodweb/wai/pull/541) ## 3.0.1 * make host configurable too (fixes #538) [#539](https://github.com/yesodweb/wai/pull/539) ## 3.0.0.5 * Support wai/warp 3.2 ## 3.0.0.3 Allow blaze-builder 0.4 ## 3.0.0.2 * Support for Win64 wai-handler-launch-3.0.2.1/LICENSE0000644000000000000000000000207512720233004014506 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. wai-handler-launch-3.0.2.1/README.md0000644000000000000000000000024612720233004014756 0ustar0000000000000000## wai-handler-launch This handles cross-platform launching and inserts Javascript code to ping the server. When the server no longer receives pings, it shuts down. wai-handler-launch-3.0.2.1/Setup.lhs0000644000000000000000000000016212720233004015304 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain wai-handler-launch-3.0.2.1/wai-handler-launch.cabal0000644000000000000000000000252112720233004020124 0ustar0000000000000000Name: wai-handler-launch Version: 3.0.2.1 Synopsis: Launch a web app in the default browser. description: API docs and the README are available at . License: MIT License-file: LICENSE Author: Michael Snoyman Maintainer: michael@snoyman.com Category: Web Build-type: Simple Cabal-version: >=1.6 extra-source-files: README.md ChangeLog.md Library Exposed-modules: Network.Wai.Handler.Launch build-depends: base >= 4 && < 5 , wai >= 3.0 && < 3.3 , warp >= 3.0 && < 3.3 , http-types >= 0.7 , transformers >= 0.2.2 , bytestring >= 0.9.1.4 , blaze-builder >= 0.2.1.4 && < 0.5 , streaming-commons , async if os(windows) c-sources: windows.c cpp-options: -DWINDOWS extra-libraries: Shell32 msvcrt else build-depends: process >= 1.0 && < 1.5 if os(darwin) cpp-options: -DMAC source-repository head type: git location: git://github.com/yesodweb/wai.git wai-handler-launch-3.0.2.1/windows.c0000644000000000000000000000051112720233004015330 0ustar0000000000000000#include #include #include void launch(int port, char *s) { int len = 8 + strlen("http://127.0.0.1:") + strlen(s); char *buff = malloc(len); _snprintf(buff, len, "http://127.0.0.1:%d/%s", port, s); ShellExecute(NULL, "open", buff, NULL, NULL, SW_SHOWNORMAL); free(buff); } wai-handler-launch-3.0.2.1/Network/0000755000000000000000000000000012720233004015126 5ustar0000000000000000wai-handler-launch-3.0.2.1/Network/Wai/0000755000000000000000000000000012720233004015646 5ustar0000000000000000wai-handler-launch-3.0.2.1/Network/Wai/Handler/0000755000000000000000000000000012720233004017223 5ustar0000000000000000wai-handler-launch-3.0.2.1/Network/Wai/Handler/Launch.hs0000644000000000000000000001707512720233004021003 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE CPP #-} module Network.Wai.Handler.Launch ( run , runUrl , runUrlPort , runHostPortUrl ) where import Network.Wai import Network.Wai.Internal import Network.HTTP.Types import qualified Network.Wai.Handler.Warp as Warp import Data.IORef import Data.Monoid (mappend) import Data.String (fromString) import Control.Concurrent (forkIO, threadDelay, newEmptyMVar, putMVar, takeMVar) import Control.Concurrent.Async (race) 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, Builder, flush) import qualified Blaze.ByteString.Builder as Blaze #if WINDOWS import Foreign import Foreign.C.String #else import System.Process (rawSystem) #endif import Data.Streaming.Blaze (newBlazeRecv, defaultStrategy) import qualified Data.Streaming.Zlib as Z ping :: IORef Bool -> Middleware ping active app req sendResponse | pathInfo req == ["_ping"] = do liftIO $ writeIORef active True 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 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 = "" 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 whole = "" 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 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 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 return $ Just (held', atFront') | otherwise = do let (held', atFront', x') = getOverlap whole x sendInner $ fromByteString held `mappend` fromByteString x' return $ Just (held', atFront') getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString) getOverlap whole x = go whole where go piece | S.null piece = ("", whole, x) | piece `S.isSuffixOf` x = let x' = S.take (S.length x - S.length piece) x atFront = S.drop (S.length piece) whole in (piece, atFront, x') | otherwise = go $ S.init piece fixHeaders :: ([Header] -> [Header]) -> [Header] -> (Bool, [Header]) fixHeaders front [] = (False, front []) fixHeaders front (("content-encoding", "gzip"):rest) = (True, front rest) fixHeaders front (x:xs) = fixHeaders (front . (:) x) xs #if WINDOWS foreign import ccall "launch" launch' :: Int -> CString -> IO () #endif launch :: Int -> String -> IO () #if WINDOWS launch port s = withCString s $ launch' port #else launch port s = forkIO (rawSystem #if MAC "open" #else "xdg-open" #endif ["http://127.0.0.1:" ++ show port ++ "/" ++ s] >> return ()) >> return () #endif run :: Application -> IO () run = runUrl "" runUrl :: String -> Application -> IO () runUrl = runUrlPort 4587 runUrlPort :: Int -> String -> Application -> IO () runUrlPort = runHostPortUrl "*4" -- | -- -- @since 3.0.1 runHostPortUrl :: String -> Int -> String -> Application -> IO () runHostPortUrl host port url app = do ready <- newEmptyMVar active <- newIORef True let settings = Warp.setPort port $ Warp.setOnException (\_ _ -> return ()) $ Warp.setHost (fromString host) $ Warp.setBeforeMainLoop (putMVar ready ()) $ Warp.defaultSettings -- Run these threads concurrently; when either one terminates or -- raises an exception, the same happens to the other. fmap (either id id) $ race -- serve app, keep updating the activity flag (Warp.runSettings settings (ping active app)) -- wait for server startup, launch browser, poll until server idle (takeMVar ready >> launch port url >> loop active) loop :: IORef Bool -> IO () loop active = do let seconds = 120 threadDelay $ 1000000 * seconds b <- readIORef active if b then writeIORef active False >> loop active else return ()