wai-handler-launch-3.0.0.5/0000755000000000000000000000000012640677145013522 5ustar0000000000000000wai-handler-launch-3.0.0.5/ChangeLog.md0000644000000000000000000000015112640677145015670 0ustar0000000000000000## 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.0.5/LICENSE0000644000000000000000000000207512640677145014533 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.0.5/README.md0000644000000000000000000000024612640677145015003 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.0.5/Setup.lhs0000644000000000000000000000016212640677145015331 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain wai-handler-launch-3.0.0.5/wai-handler-launch.cabal0000644000000000000000000000246612640677145020161 0ustar0000000000000000Name: wai-handler-launch Version: 3.0.0.5 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 if os(windows) c-sources: windows.c cpp-options: -DWINDOWS extra-libraries: Shell32 msvcrt else build-depends: process >= 1.0 && < 1.3 if os(darwin) cpp-options: -DMAC source-repository head type: git location: git://github.com/yesodweb/wai.git wai-handler-launch-3.0.0.5/windows.c0000644000000000000000000000051112640677145015355 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.0.5/Network/0000755000000000000000000000000012640677145015153 5ustar0000000000000000wai-handler-launch-3.0.0.5/Network/Wai/0000755000000000000000000000000012640677145015673 5ustar0000000000000000wai-handler-launch-3.0.0.5/Network/Wai/Handler/0000755000000000000000000000000012640677145017250 5ustar0000000000000000wai-handler-launch-3.0.0.5/Network/Wai/Handler/Launch.hs0000644000000000000000000001555312640677145021027 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE CPP #-} module Network.Wai.Handler.Launch ( run , runUrl , runUrlPort ) 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 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, 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 var app req sendResponse | pathInfo req == ["_ping"] = do liftIO $ writeIORef var 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 port url app = do x <- newIORef True _ <- forkIO $ Warp.runSettings ( Warp.setPort port $ Warp.setOnException (\_ _ -> return ()) $ Warp.setHost "*4" Warp.defaultSettings) $ ping x app launch port url loop x loop :: IORef Bool -> IO () loop x = do let seconds = 120 threadDelay $ 1000000 * seconds b <- readIORef x if b then writeIORef x False >> loop x else return ()