{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}
module Network.Wai.Handler.Launch
    ( run
    , runUrl
    , runUrlPort
    , runHostPortUrl
    , runHostPortFullUrl
    ) 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 Data.ByteString.Builder (Builder, byteString)
import qualified Data.ByteString.Builder.Extra as Builder (flush)
#if WINDOWS
import Foreign
import Foreign.C.String
#else
import System.Process (rawSystem)
#endif
import Data.Streaming.ByteString.Builder as B (newBuilderRecv, defaultStrategy)
import qualified Data.Streaming.Zlib as Z

ping :: IORef Bool -> Middleware
ping :: IORef Bool -> Middleware
ping  IORef Bool
active Application
app Request
req Response -> IO ResponseReceived
sendResponse
    | Request -> [Text]
pathInfo Request
req forall a. Eq a => a -> a -> Bool
== [Text
"_ping"] = do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
active Bool
True
        Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 [] ByteString
""
    | Bool
otherwise = Application
app Request
req forall a b. (a -> b) -> a -> b
$ \Response
res -> do
        let isHtml :: [(a, ByteString)] -> Bool
isHtml [(a, ByteString)]
hs =
                case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"content-type" [(a, ByteString)]
hs of
                    Just ByteString
ct -> ByteString
"text/html" ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
ct
                    Maybe ByteString
Nothing -> Bool
False
        if forall {a}. (Eq a, IsString a) => [(a, ByteString)] -> Bool
isHtml forall a b. (a -> b) -> a -> b
$ Response -> ResponseHeaders
responseHeaders Response
res
            then do
                let (Status
s, ResponseHeaders
hs, (StreamingBody -> IO a) -> IO a
withBody) = forall a.
Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
responseToStream Response
res
                    (Bool
isEnc, ResponseHeaders
headers') = (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> (Bool, ResponseHeaders)
fixHeaders forall a. a -> a
id ResponseHeaders
hs
                    headers'' :: ResponseHeaders
headers'' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
x, ByteString
_) -> HeaderName
x forall a. Eq a => a -> a -> Bool
/= HeaderName
"content-length") ResponseHeaders
headers'
                forall {a}. (StreamingBody -> IO a) -> IO a
withBody forall a b. (a -> b) -> a -> b
$ \StreamingBody
body ->
                    Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> StreamingBody -> Response
responseStream Status
s ResponseHeaders
headers'' forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
sendChunk IO ()
flush ->
                        (Builder -> IO ()) -> IO () -> StreamingBody -> IO ()
addInsideHead Builder -> IO ()
sendChunk IO ()
flush forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
sendChunk' IO ()
flush' ->
                            if Bool
isEnc
                                then (Builder -> IO ()) -> IO () -> StreamingBody -> IO ()
decode Builder -> IO ()
sendChunk' IO ()
flush' StreamingBody
body
                                else StreamingBody
body Builder -> IO ()
sendChunk' IO ()
flush'
            else Response -> IO ResponseReceived
sendResponse Response
res

decode :: (Builder -> IO ()) -> IO ()
       -> StreamingBody
       -> IO ()
decode :: (Builder -> IO ()) -> IO () -> StreamingBody -> IO ()
decode Builder -> IO ()
sendInner IO ()
flushInner StreamingBody
streamingBody = do
    (BuilderRecv
blazeRecv, BuilderFinish
blazeFinish) <- BufferAllocStrategy -> IO (BuilderRecv, BuilderFinish)
newBuilderRecv BufferAllocStrategy
defaultStrategy
    Inflate
inflate <- WindowBits -> IO Inflate
Z.initInflate forall a b. (a -> b) -> a -> b
$ Int -> WindowBits
Z.WindowBits Int
31
    let send :: Builder -> IO ()
send Builder
builder = BuilderRecv
blazeRecv Builder
builder forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO ByteString -> IO ()
goBuilderPopper
        goBuilderPopper :: IO ByteString -> IO ()
goBuilderPopper IO ByteString
popper = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
            ByteString
bs <- IO ByteString
popper
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) forall a b. (a -> b) -> a -> b
$ do
                Inflate -> ByteString -> IO Popper
Z.feedInflate Inflate
inflate ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Popper -> IO ()
goZlibPopper
                IO ()
loop
        goZlibPopper :: Popper -> IO ()
goZlibPopper Popper
popper = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
            PopperRes
res <- Popper
popper
            case PopperRes
res of
                PopperRes
Z.PRDone -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Z.PRNext ByteString
bs -> do
                    Builder -> IO ()
sendInner forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
bs
                    IO ()
loop
                Z.PRError ZlibException
e -> forall e a. Exception e => e -> IO a
throwIO ZlibException
e
    StreamingBody
streamingBody Builder -> IO ()
send (Builder -> IO ()
send Builder
Builder.flush)
    Maybe ByteString
mbs <- BuilderFinish
blazeFinish
    case Maybe ByteString
mbs of
        Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just ByteString
bs -> Inflate -> ByteString -> IO Popper
Z.feedInflate Inflate
inflate ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Popper -> IO ()
goZlibPopper
    Inflate -> IO ByteString
Z.finishInflate Inflate
inflate forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Builder -> IO ()
sendInner forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString

toInsert :: S.ByteString
toInsert :: ByteString
toInsert = ByteString
"<script>setInterval(function(){var x;if(window.XMLHttpRequest){x=new XMLHttpRequest();}else{x=new ActiveXObject(\"Microsoft.XMLHTTP\");}x.open(\"GET\",\"/_ping?\" + (new Date()).getTime(),true);x.send();},60000)</script>"

addInsideHead :: (Builder -> IO ())
              -> IO ()
              -> StreamingBody
              -> IO ()
addInsideHead :: (Builder -> IO ()) -> IO () -> StreamingBody -> IO ()
addInsideHead Builder -> IO ()
sendInner IO ()
flushInner StreamingBody
streamingBody = do
    (BuilderRecv
blazeRecv, BuilderFinish
blazeFinish) <- BufferAllocStrategy -> IO (BuilderRecv, BuilderFinish)
newBuilderRecv BufferAllocStrategy
defaultStrategy
    IORef (Maybe (ByteString, ByteString))
ref <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (ByteString
S.empty, ByteString
whole)
    StreamingBody
streamingBody (forall {t}.
(t -> IO (IO ByteString))
-> IORef (Maybe (ByteString, ByteString)) -> t -> IO ()
inner BuilderRecv
blazeRecv IORef (Maybe (ByteString, ByteString))
ref) (BuilderRecv -> IORef (Maybe (ByteString, ByteString)) -> IO ()
flush BuilderRecv
blazeRecv IORef (Maybe (ByteString, ByteString))
ref)
    Maybe (ByteString, ByteString)
state <- forall a. IORef a -> IO a
readIORef IORef (Maybe (ByteString, ByteString))
ref
    Maybe ByteString
mbs <- BuilderFinish
blazeFinish
    Maybe (ByteString, ByteString)
held <- case Maybe ByteString
mbs of
        Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ByteString, ByteString)
state
        Just ByteString
bs -> Maybe (ByteString, ByteString)
-> ByteString -> IO (Maybe (ByteString, ByteString))
push Maybe (ByteString, ByteString)
state ByteString
bs
    case Maybe (ByteString, ByteString)
state of
        Maybe (ByteString, ByteString)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just (ByteString
held, ByteString
_) -> Builder -> IO ()
sendInner forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
toInsert
  where
    whole :: ByteString
whole = ByteString
"<head>"

    flush :: BuilderRecv -> IORef (Maybe (ByteString, ByteString)) -> IO ()
flush BuilderRecv
blazeRecv IORef (Maybe (ByteString, ByteString))
ref = forall {t}.
(t -> IO (IO ByteString))
-> IORef (Maybe (ByteString, ByteString)) -> t -> IO ()
inner BuilderRecv
blazeRecv IORef (Maybe (ByteString, ByteString))
ref Builder
Builder.flush

    inner :: (t -> IO (IO ByteString))
-> IORef (Maybe (ByteString, ByteString)) -> t -> IO ()
inner t -> IO (IO ByteString)
blazeRecv IORef (Maybe (ByteString, ByteString))
ref t
builder = do
        Maybe (ByteString, ByteString)
state0 <- forall a. IORef a -> IO a
readIORef IORef (Maybe (ByteString, ByteString))
ref
        IO ByteString
popper <- t -> IO (IO ByteString)
blazeRecv t
builder
        let loop :: Maybe (ByteString, ByteString) -> IO ()
loop Maybe (ByteString, ByteString)
state = do
                ByteString
bs <- IO ByteString
popper
                if ByteString -> Bool
S.null ByteString
bs
                    then forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (ByteString, ByteString))
ref Maybe (ByteString, ByteString)
state
                    else Maybe (ByteString, ByteString)
-> ByteString -> IO (Maybe (ByteString, ByteString))
push Maybe (ByteString, ByteString)
state ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (ByteString, ByteString) -> IO ()
loop
        Maybe (ByteString, ByteString) -> IO ()
loop Maybe (ByteString, ByteString)
state0

    push :: Maybe (ByteString, ByteString)
-> ByteString -> IO (Maybe (ByteString, ByteString))
push Maybe (ByteString, ByteString)
Nothing ByteString
x = Builder -> IO ()
sendInner (ByteString -> Builder
byteString ByteString
x) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    push (Just (ByteString
held, ByteString
atFront)) ByteString
x
        | ByteString
atFront ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
x = do
            let y :: ByteString
y = Int -> ByteString -> ByteString
S.drop (ByteString -> Int
S.length ByteString
atFront) ByteString
x
            Builder -> IO ()
sendInner forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held
              forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
atFront
              forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
toInsert
              forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
y
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        | ByteString
whole ByteString -> ByteString -> Bool
`S.isInfixOf` ByteString
x = do
            let (ByteString
before, ByteString
rest) = ByteString -> ByteString -> (ByteString, ByteString)
S.breakSubstring ByteString
whole ByteString
x
            let after :: ByteString
after = Int -> ByteString -> ByteString
S.drop (ByteString -> Int
S.length ByteString
whole) ByteString
rest
            Builder -> IO ()
sendInner forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held
              forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
before
              forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
whole
              forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
toInsert
              forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
after
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        | ByteString
x ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
atFront = do
            let held' :: ByteString
held' = ByteString
held ByteString -> ByteString -> ByteString
`S.append` ByteString
x
                atFront' :: ByteString
atFront' = Int -> ByteString -> ByteString
S.drop (ByteString -> Int
S.length ByteString
x) ByteString
atFront
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (ByteString
held', ByteString
atFront')
        | Bool
otherwise = do
            let (ByteString
held', ByteString
atFront', ByteString
x') = ByteString -> ByteString -> (ByteString, ByteString, ByteString)
getOverlap ByteString
whole ByteString
x
            Builder -> IO ()
sendInner forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
x'
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (ByteString
held', ByteString
atFront')

getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)
getOverlap :: ByteString -> ByteString -> (ByteString, ByteString, ByteString)
getOverlap ByteString
whole ByteString
x =
    ByteString -> (ByteString, ByteString, ByteString)
go ByteString
whole
  where
    go :: ByteString -> (ByteString, ByteString, ByteString)
go ByteString
piece
        | ByteString -> Bool
S.null ByteString
piece = (ByteString
"", ByteString
whole, ByteString
x)
        | ByteString
piece ByteString -> ByteString -> Bool
`S.isSuffixOf` ByteString
x =
            let x' :: ByteString
x' = Int -> ByteString -> ByteString
S.take (ByteString -> Int
S.length ByteString
x forall a. Num a => a -> a -> a
- ByteString -> Int
S.length ByteString
piece) ByteString
x
                atFront :: ByteString
atFront = Int -> ByteString -> ByteString
S.drop (ByteString -> Int
S.length ByteString
piece) ByteString
whole
             in (ByteString
piece, ByteString
atFront, ByteString
x')
        | Bool
otherwise = ByteString -> (ByteString, ByteString, ByteString)
go forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
S.init ByteString
piece

fixHeaders :: ([Header] -> [Header])
           -> [Header]
           -> (Bool, [Header])
fixHeaders :: (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> (Bool, ResponseHeaders)
fixHeaders ResponseHeaders -> ResponseHeaders
front [] = (Bool
False, ResponseHeaders -> ResponseHeaders
front [])
fixHeaders ResponseHeaders -> ResponseHeaders
front ((HeaderName
"content-encoding", ByteString
"gzip"):ResponseHeaders
rest) = (Bool
True, ResponseHeaders -> ResponseHeaders
front ResponseHeaders
rest)
fixHeaders ResponseHeaders -> ResponseHeaders
front ((HeaderName, ByteString)
x:ResponseHeaders
xs) = (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> (Bool, ResponseHeaders)
fixHeaders (ResponseHeaders -> ResponseHeaders
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) (HeaderName, ByteString)
x) ResponseHeaders
xs

#if WINDOWS
foreign import ccall "launch"
    launch' :: CString -> IO ()
#endif

launch :: String -> IO ()

#if WINDOWS
launch url = withCString url launch'
#else
launch :: [Char] -> IO ()
launch [Char]
url = IO () -> IO ThreadId
forkIO ([Char] -> [[Char]] -> IO ExitCode
rawSystem
#if MAC
    "open"
#else
    [Char]
"xdg-open"
#endif
    [[Char]
url] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

run :: Application -> IO ()
run :: Application -> IO ()
run = [Char] -> Application -> IO ()
runUrl [Char]
""

runUrl :: String -> Application -> IO ()
runUrl :: [Char] -> Application -> IO ()
runUrl = Int -> [Char] -> Application -> IO ()
runUrlPort Int
4587

runUrlPort :: Int -> String -> Application -> IO ()
runUrlPort :: Int -> [Char] -> Application -> IO ()
runUrlPort = [Char] -> Int -> [Char] -> Application -> IO ()
runHostPortUrl [Char]
"*4"

-- |
--
-- @since 3.0.1
runHostPortUrl :: String -> Int -> String -> Application -> IO ()
runHostPortUrl :: [Char] -> Int -> [Char] -> Application -> IO ()
runHostPortUrl [Char]
host Int
port [Char]
url Application
app = [Char] -> Int -> [Char] -> Application -> IO ()
runHostPortFullUrl [Char]
host Int
port ([Char]
"http://127.0.0.1:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
port forall a. [a] -> [a] -> [a]
++ [Char]
"/" forall a. [a] -> [a] -> [a]
++ [Char]
url) Application
app

-- | Generic version of runHostPortUrl that allows arbitrary URLs to launch
--
-- @since 3.0.2.5
runHostPortFullUrl :: String -> Int -> String -> Application -> IO ()
runHostPortFullUrl :: [Char] -> Int -> [Char] -> Application -> IO ()
runHostPortFullUrl [Char]
host Int
port [Char]
url Application
app = do
    MVar ()
ready <- forall a. IO (MVar a)
newEmptyMVar
    IORef Bool
active <- forall a. a -> IO (IORef a)
newIORef Bool
True
    let settings :: Settings
settings =
          Int -> Settings -> Settings
Warp.setPort Int
port forall a b. (a -> b) -> a -> b
$
          (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
Warp.setOnException (\Maybe Request
_ SomeException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall a b. (a -> b) -> a -> b
$
          HostPreference -> Settings -> Settings
Warp.setHost (forall a. IsString a => [Char] -> a
fromString [Char]
host) forall a b. (a -> b) -> a -> b
$
          IO () -> Settings -> Settings
Warp.setBeforeMainLoop (forall a. MVar a -> a -> IO ()
putMVar MVar ()
ready ()) forall a b. (a -> b) -> a -> b
$
          Settings
Warp.defaultSettings
    -- Run these threads concurrently; when either one terminates or
    -- raises an exception, the same happens to the other.
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ forall a b. IO a -> IO b -> IO (Either a b)
race
      -- serve app, keep updating the activity flag
      (Settings -> Application -> IO ()
Warp.runSettings Settings
settings (IORef Bool -> Middleware
ping IORef Bool
active Application
app))
      -- wait for server startup, launch browser, poll until server idle
      (forall a. MVar a -> IO a
takeMVar MVar ()
ready forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
launch [Char]
url forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IORef Bool -> IO ()
loop IORef Bool
active)

loop :: IORef Bool -> IO ()
loop :: IORef Bool -> IO ()
loop IORef Bool
active = do
    let seconds :: Int
seconds = Int
120
    Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
1000000 forall a. Num a => a -> a -> a
* Int
seconds
    Bool
b <- forall a. IORef a -> IO a
readIORef IORef Bool
active
    if Bool
b
        then forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
active Bool
False forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IORef Bool -> IO ()
loop IORef Bool
active
        else forall (m :: * -> *) a. Monad m => a -> m a
return ()