diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Network/Wai/Handler/Launch.hs b/Network/Wai/Handler/Launch.hs
new file mode 100644
--- /dev/null
+++ b/Network/Wai/Handler/Launch.hs
@@ -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 "" $$ 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 = ""
+ 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 ()
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/wai-handler-launch.cabal b/wai-handler-launch.cabal
new file mode 100644
--- /dev/null
+++ b/wai-handler-launch.cabal
@@ -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
diff --git a/windows.c b/windows.c
new file mode 100644
--- /dev/null
+++ b/windows.c
@@ -0,0 +1,7 @@
+#include
+#include
+
+void launch(void)
+{
+ ShellExecute(NULL, "open", "http://localhost:4587/", NULL, NULL, SW_SHOWNORMAL);
+}