    {-# 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
        (blazeRecv, blazeFinish) <- BufferAllocStrategy -> IO (BuilderRecv, BuilderFinish)
    newBuilderRecv BufferAllocStrategy
    defaultStrategy
        inflate <- Z.initInflate $ Z.WindowBits 31
        let 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
    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
                bs <- BuilderPopper
    popper
                unless (S.null bs) $ do
                    Z.feedInflate inflate bs >>= goZlibPopper
                    loop
            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
                res <- Popper
    popper
                case 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. (HasCallStack, Exception e) => e -> IO a
    throwIO ZlibException
    e
        streamingBody send (send Builder.flush)
        mbs <- blazeFinish
        case 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
        Z.finishInflate inflate >>= sendInner . 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
        (blazeRecv, blazeFinish) <- BufferAllocStrategy -> IO (BuilderRecv, BuilderFinish)
    newBuilderRecv BufferAllocStrategy
    defaultStrategy
        ref <- newIORef $ Just (S.empty, whole)
        streamingBody (inner blazeRecv ref) (flush blazeRecv ref)
        state <- readIORef ref
        mbs <- blazeFinish
        held <- case 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 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
            state0 <- IORef (Maybe (ByteString, ByteString))
    -> IO (Maybe (ByteString, ByteString))
    forall a. IORef a -> IO a
    readIORef IORef (Maybe (ByteString, ByteString))
    ref
            popper <- blazeRecv builder
            let loop Maybe (ByteString, ByteString)
    state = do
                    bs <- BuilderPopper
    popper
                    if S.null bs
                        then writeIORef ref state
                        else push state bs >>= loop
            loop 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
        ready <- IO (MVar ())
    forall a. IO (MVar a)
    newEmptyMVar
        active <- newIORef True
        let 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.
        fmap (either id id) $ race
          -- serve app, keep updating the activity flag
          (Warp.runSettings settings (ping active app))
          -- wait for server startup, launch browser, poll until server idle
          (takeMVar ready >> launch url >> loop 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
        b <- IORef Bool -> IO Bool
    forall a. IORef a -> IO a
    readIORef IORef Bool
    active
        if b
            then writeIORef active False >> loop active
            else return ()