{-# 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 ()