wai-handler-launch 0.0.2 → 0.0.3
raw patch · 6 files changed
+245/−236 lines, 6 filessetup-changed
Files
- LICENSE +30/−30
- Network/Wai/Handler/Launch.hs +163/−159
- Setup.hs +0/−2
- Setup.lhs +7/−0
- wai-handler-launch.cabal +33/−33
- windows.c +12/−12
LICENSE view
@@ -1,30 +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. +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
@@ -1,159 +1,163 @@-{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE CPP #-} -module Network.Wai.Handler.Launch - ( run - , runUrl - ) 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' :: Int -> CString -> IO () -#endif - -launch :: String -> IO () - -#if WINDOWS -launch s = withCString s $ launch' 4587 -#else -launch s = forkIO (rawSystem -#if MAC - "open" -#else - "xdg-open" -#endif - ["http://127.0.0.1:4587/" ++ s] >> return ()) >> return () -#endif - -run :: Application -> IO () -run = runUrl "" - -runUrl :: String -> Application -> IO () -runUrl url app = do - x <- newIORef True - forkIO $ Warp.runSettings Warp.defaultSettings - { Warp.settingsPort = 4587 - , Warp.settingsOnException = const $ return () - , Warp.settingsHost = "127.0.0.1" - } $ ping x app - launch 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 () +{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}+module Network.Wai.Handler.Launch+ ( run+ , runUrl+ ) where++import Network.Wai+import Network.HTTP.Types+import qualified Network.Wai.Handler.Warp as Warp+import Data.IORef+import Control.Concurrent+import Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString as S+import Data.Enumerator (($$), joinI, Enumeratee, Stream (..), Iteratee (..), Step (..))+import Blaze.ByteString.Builder (fromByteString)+#if WINDOWS+import Foreign+import Foreign.C.String+#else+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 :: ([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 :: String -> IO ()++#if WINDOWS+launch s = withCString s $ launch' 4587+#else+launch s = forkIO (rawSystem+#if MAC+ "open"+#else+ "xdg-open"+#endif+ ["http://127.0.0.1:4587/" ++ s] >> return ()) >> return ()+#endif++run :: Application -> IO ()+run = runUrl ""++runUrl :: String -> Application -> IO ()+runUrl url app = do+ x <- newIORef True+ _ <- forkIO $ Warp.runSettings Warp.defaultSettings+ { Warp.settingsPort = 4587+ , Warp.settingsOnException = const $ return ()+ , Warp.settingsHost = "127.0.0.1"+ } $ ping x app+ launch 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 ()
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple -main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
wai-handler-launch.cabal view
@@ -1,33 +1,33 @@-Name: wai-handler-launch -Version: 0.0.2 -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 +Name: wai-handler-launch+Version: 0.0.3+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
@@ -1,12 +1,12 @@-#include <windows.h> -#include <shellapi.h> -#include <stdio.h> - -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); -} +#include <windows.h>+#include <shellapi.h>+#include <stdio.h>++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);+}