{-# 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 [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text
"_ping"] = do
        IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
active Bool
True
        Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 [] ByteString
""
    | Bool
otherwise = Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
res -> do
        let isHtml :: [(a, ByteString)] -> Bool
isHtml [(a, ByteString)]
hs =
                case a -> [(a, ByteString)] -> Maybe ByteString
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 ResponseHeaders -> Bool
forall {a}. (Eq a, IsString a) => [(a, ByteString)] -> Bool
isHtml (ResponseHeaders -> Bool) -> ResponseHeaders -> Bool
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) = Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
forall a.
Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
responseToStream Response
res
                    (Bool
isEnc, ResponseHeaders
headers') = (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> (Bool, ResponseHeaders)
fixHeaders ResponseHeaders -> ResponseHeaders
forall a. a -> a
id ResponseHeaders
hs
                    headers'' :: ResponseHeaders
headers'' = ((HeaderName, ByteString) -> Bool)
-> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
x, ByteString
_) -> HeaderName
x HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
"content-length") ResponseHeaders
headers'
                (StreamingBody -> IO ResponseReceived) -> IO ResponseReceived
forall {a}. (StreamingBody -> IO a) -> IO a
withBody ((StreamingBody -> IO ResponseReceived) -> IO ResponseReceived)
-> (StreamingBody -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \StreamingBody
body ->
                    Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> StreamingBody -> Response
responseStream Status
s ResponseHeaders
headers'' (StreamingBody -> Response) -> StreamingBody -> Response
forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
sendChunk IO ()
flush ->
                        (Builder -> IO ()) -> IO () -> StreamingBody -> IO ()
addInsideHead Builder -> IO ()
sendChunk IO ()
flush (StreamingBody -> IO ()) -> StreamingBody -> IO ()
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 (WindowBits -> IO Inflate) -> WindowBits -> IO Inflate
forall a b. (a -> b) -> a -> b
$ Int -> WindowBits
Z.WindowBits Int
31
    let send :: Builder -> IO ()
send Builder
builder = BuilderRecv
blazeRecv Builder
builder IO BuilderPopper -> (BuilderPopper -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BuilderPopper -> IO ()
goBuilderPopper
        goBuilderPopper :: BuilderPopper -> IO ()
goBuilderPopper BuilderPopper
popper = (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
            ByteString
bs <- BuilderPopper
popper
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Inflate -> ByteString -> IO Popper
Z.feedInflate Inflate
inflate ByteString
bs IO Popper -> (Popper -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Popper -> IO ()
goZlibPopper
                IO ()
loop
        goZlibPopper :: Popper -> IO ()
goZlibPopper Popper
popper = (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
            PopperRes
res <- Popper
popper
            case PopperRes
res of
                PopperRes
Z.PRDone -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Z.PRNext ByteString
bs -> do
                    Builder -> IO ()
sendInner (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
bs
                    IO ()
loop
                Z.PRError ZlibException
e -> ZlibException -> IO ()
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 -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just ByteString
bs -> Inflate -> ByteString -> IO Popper
Z.feedInflate Inflate
inflate ByteString
bs IO Popper -> (Popper -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Popper -> IO ()
goZlibPopper
    Inflate -> BuilderPopper
Z.finishInflate Inflate
inflate BuilderPopper -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Builder -> IO ()
sendInner (Builder -> IO ())
-> (ByteString -> Builder) -> ByteString -> IO ()
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 <- Maybe (ByteString, ByteString)
-> IO (IORef (Maybe (ByteString, ByteString)))
forall a. a -> IO (IORef a)
newIORef (Maybe (ByteString, ByteString)
 -> IO (IORef (Maybe (ByteString, ByteString))))
-> Maybe (ByteString, ByteString)
-> IO (IORef (Maybe (ByteString, ByteString)))
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
S.empty, ByteString
whole)
    StreamingBody
streamingBody (BuilderRecv
-> IORef (Maybe (ByteString, ByteString)) -> Builder -> IO ()
forall {t}.
(t -> IO BuilderPopper)
-> 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 <- IORef (Maybe (ByteString, ByteString))
-> IO (Maybe (ByteString, ByteString))
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 -> Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a. a -> IO a
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 -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just (ByteString
held, ByteString
_) -> Builder -> IO ()
sendInner (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held Builder -> Builder -> Builder
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 = BuilderRecv
-> IORef (Maybe (ByteString, ByteString)) -> Builder -> IO ()
forall {t}.
(t -> IO BuilderPopper)
-> IORef (Maybe (ByteString, ByteString)) -> t -> IO ()
inner BuilderRecv
blazeRecv IORef (Maybe (ByteString, ByteString))
ref Builder
Builder.flush

    inner :: (t -> IO BuilderPopper)
-> IORef (Maybe (ByteString, ByteString)) -> t -> IO ()
inner t -> IO BuilderPopper
blazeRecv IORef (Maybe (ByteString, ByteString))
ref t
builder = do
        Maybe (ByteString, ByteString)
state0 <- IORef (Maybe (ByteString, ByteString))
-> IO (Maybe (ByteString, ByteString))
forall a. IORef a -> IO a
readIORef IORef (Maybe (ByteString, ByteString))
ref
        BuilderPopper
popper <- t -> IO BuilderPopper
blazeRecv t
builder
        let loop :: Maybe (ByteString, ByteString) -> IO ()
loop Maybe (ByteString, ByteString)
state = do
                ByteString
bs <- BuilderPopper
popper
                if ByteString -> Bool
S.null ByteString
bs
                    then IORef (Maybe (ByteString, ByteString))
-> Maybe (ByteString, ByteString) -> IO ()
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 IO (Maybe (ByteString, ByteString))
-> (Maybe (ByteString, ByteString) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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) IO ()
-> IO (Maybe (ByteString, ByteString))
-> IO (Maybe (ByteString, ByteString))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ByteString, ByteString)
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 (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held
              Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
atFront
              Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
toInsert
              Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
y
            Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ByteString, ByteString)
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 (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held
              Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
before
              Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
whole
              Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
toInsert
              Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
after
            Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ByteString, ByteString)
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
            Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ByteString, ByteString)
 -> IO (Maybe (ByteString, ByteString)))
-> Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> Maybe (ByteString, ByteString)
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 (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
x'
            Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ByteString, ByteString)
 -> IO (Maybe (ByteString, ByteString)))
-> Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> Maybe (ByteString, ByteString)
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 Int -> Int -> Int
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 (ByteString -> (ByteString, ByteString, ByteString))
-> ByteString -> (ByteString, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
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 (ResponseHeaders -> ResponseHeaders)
-> (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders
-> ResponseHeaders
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] IO ExitCode -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) IO ThreadId -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
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:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
port [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [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 <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    IORef Bool
active <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
    let settings :: Settings
settings =
          Int -> Settings -> Settings
Warp.setPort Int
port (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
          (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
Warp.setOnException (\Maybe Request
_ SomeException
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
          HostPreference -> Settings -> Settings
Warp.setHost ([Char] -> HostPreference
forall a. IsString a => [Char] -> a
fromString [Char]
host) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
          IO () -> Settings -> Settings
Warp.setBeforeMainLoop (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
ready ()) (Settings -> Settings) -> Settings -> Settings
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.
    (Either () () -> ()) -> IO (Either () ()) -> IO ()
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((() -> ()) -> (() -> ()) -> Either () () -> ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either () -> ()
forall a. a -> a
id () -> ()
forall a. a -> a
id) (IO (Either () ()) -> IO ()) -> IO (Either () ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO () -> IO (Either () ())
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
      (MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
ready IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
launch [Char]
url IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
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 (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
1000000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
seconds
    Bool
b <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
active
    if Bool
b
        then IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
active Bool
False IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IORef Bool -> IO ()
loop IORef Bool
active
        else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()