wai-handler-launch (empty) → 0.0.0
raw patch · 5 files changed
+219/−0 lines, 5 filesdep +basedep +blaze-builderdep +blaze-builder-enumeratorsetup-changed
Dependencies added: base, blaze-builder, blaze-builder-enumerator, bytestring, enumerator, http-types, process, transformers, wai, warp, zlib-enum
Files
- LICENSE +30/−0
- Network/Wai/Handler/Launch.hs +147/−0
- Setup.hs +2/−0
- wai-handler-launch.cabal +33/−0
- windows.c +7/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Michael Snoyman + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Michael Snoyman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/Wai/Handler/Launch.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} +module Network.Wai.Handler.Launch (run) where + +import Network.Wai +import Network.HTTP.Types +import qualified Network.Wai.Handler.Warp as Warp +import Data.IORef +import Control.Concurrent +import Foreign +import Foreign.C.String +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString as S +import Data.Enumerator (($$), enumList, joinI, Enumeratee, Stream (..), Iteratee (..), Step (..)) +import Blaze.ByteString.Builder (fromByteString) +#if !WINDOWS +import System.Cmd (rawSystem) +#endif +import Codec.Zlib.Enum (ungzip) +import Blaze.ByteString.Builder.Enumerator (builderToByteString) +import qualified Data.Enumerator.List as EL +import Control.Monad.Trans.Class (lift) + +ping :: IORef Bool -> Middleware +ping var app req + | pathInfo req == ["_ping"] = do + liftIO $ writeIORef var True + return $ responseLBS status200 [] "" + | otherwise = do + res <- app req + 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 + _ -> do + let renum = responseEnumerator res + return $ ResponseEnumerator $ \f -> renum $ \status headers -> + if isHtml headers + then do + let (isEnc, headers') = fixHeaders id headers + let headers'' = filter (\(x, _) -> x /= "content-length") headers' + let fixEnc x = + if isEnc + then joinI $ ungzip $$ x + else x + 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'' + else f status headers + +insideHead :: S.ByteString -> Enumeratee S.ByteString S.ByteString IO a +insideHead toInsert = + go "" whole + where + whole = "<head>" + go :: S.ByteString -> S.ByteString -> Step S.ByteString IO a -> Iteratee S.ByteString IO (Step S.ByteString IO a) + go held atFront step = do + mx <- EL.head + case mx of + Nothing -> feedDone $ Chunks [held, toInsert] + Just x + | atFront `S.isPrefixOf` x -> do + let y = S.drop (S.length atFront) x + let stream = Chunks [held, atFront, toInsert, y] + feedDone stream + | whole `S.isInfixOf` x -> do + let (before, rest) = S.breakSubstring whole x + let after = S.drop (S.length whole) rest + feedDone $ Chunks [held, before, whole, toInsert, after] + | x `S.isPrefixOf` atFront -> go + (held `S.append` x) + (S.drop (S.length x) atFront) + step + | otherwise -> do + let (held', atFront', x') = getOverlap whole x + feedCont held' atFront' $ Chunks [held, x'] + where + --feedDone :: Stream S.ByteString -> Iteratee S.ByteString IO (Step S.ByteString IO a) + feedDone stream = + case step of + Continue k -> do + step' <- lift $ runIteratee $ k stream + EL.map id step' + Yield b s -> return $ Yield b s + Error e -> return $ Error e + + --feedCont :: Monad m => S.ByteString -> S.ByteString -> Stream S.ByteString -> Iteratee S.ByteString m (Step S.ByteString m a) + feedCont held atFront stream = do + case step of + Continue k -> do + step' <- lift $ runIteratee $ k stream + go held atFront step' + Yield b s -> return $ Yield b s + Error e -> return $ Error e + +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 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 :: IO () +#else +launch :: IO () +launch = forkIO (rawSystem +#if MAC + "open" +#else + "xdg-open" +#endif + ["http://localhost:4587/"] >> return ()) >> return () +#endif + +run :: Application -> IO () +run app = do + x <- newIORef True + forkIO $ Warp.runSettings Warp.defaultSettings + { Warp.settingsPort = 4587 + , Warp.settingsOnException = const $ return () + } $ ping x app + launch + 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 ()
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ wai-handler-launch.cabal view
@@ -0,0 +1,33 @@+Name: wai-handler-launch +Version: 0.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: BSD3 +License-file: LICENSE +Author: Michael Snoyman +Maintainer: michael@snoyman.com +Category: Web +Build-type: Simple +Cabal-version: >=1.2 + +Library + Exposed-modules: Network.Wai.Handler.Launch + build-depends: base >= 4 && < 5 + , wai >= 0.4 && < 0.5 + , warp >= 0.4 && < 0.5 + , http-types >= 0.6 && < 0.7 + , transformers >= 0.2 && < 0.3 + , bytestring >= 0.9 && < 1 + , blaze-builder >= 0.2 && < 0.4 + , enumerator >= 0.4 && < 0.5 + , blaze-builder-enumerator>= 0.2 && < 0.3 + , zlib-enum >= 0.2 && < 0.3 + if os(windows) + c-sources: windows.c + cpp-options: -DWINDOWS + extra-libraries: Shell32 + else + if os(darwin) + cpp-options: -DMAC + else + build-depends: process >= 1.0 && < 1.2
+ windows.c view
@@ -0,0 +1,7 @@+#include <windows.h> +#include <shellapi.h> + +void launch(void) +{ + ShellExecute(NULL, "open", "http://localhost:4587/", NULL, NULL, SW_SHOWNORMAL); +}