For my logdl tool, I wanted to add an option to wait for the server to appear and disappear. That should be easy: make a request in a loop until the server starts (or stops) replying.

Waiting until the server appears

I can use httpNoBody request manager to make an HTTP request, and if it fails, an HttpException is thrown and catch can catch it. Thus the HTTP check looks like this:

1
2

isHTTPError = (httpNoBody request manager $> False)
  `catch` (\(_ :: HttpException) -> threadDelay 1_000_000 $> True)

This IO Bool action returns an IO False if the request was successful and an IO True otherwise — to run the action while it returns True. Now I need a loop, a simple one could have this signature: while :: Bool -> (), however this action is inside IO, so I implemented a monadic version:

1
2
3
4
5

-- | Repeats the monadic action @m@ while it returns @True@.
whileM :: Monad m => m Bool -> m ()
whileM m = do
  b <- m
  when b $ whileM m

This is a very simple implementation indeed! Now it’s trivial to have the core of the wait function: whileM isHTTPError (the rest of my waitForAppearance function is preparing the request and it’s in a ReaderT monad).

Printing a message only once

For an improvement, I want to print a message that the program is waiting, and it should happen only once. How to do that?!

whileM could be extended to keep track of the current iteration count, but that is modifying the function (imagine the function is in a library that we can’t easily change; in fact, there are multiple monadic loop functions in the monad-loops library) and I wanted to avoid that if possible.

Well, I’m back to our favorite standard monads and monad transformers! Updating state is the job for State, or, more precisely, for StateT x IO because I need to do IO as well. Does it mean that I need another function like whileM that knows how to work with a StateT? No need for that since whileM already works with any Monad and StateT is a Monad.

So my first approach was to get the is-first-fail flag inside the catch block (where I need it), thus the whole computation after whileM would be of type StateT Bool IO Bool (i.e., a state that contains the is-first-fail flag (the first Bool), can encompass computations in IO, and returns a value of type Bool), and to get an IO () out of it, I need to run the state (here with evalStateT because I don’t care about the final state):

1
2
3
4
5
6
7
8
9
10
11
12

waitForAppearance' :: Manager -> Request -> IO ()
waitForAppearance' manager request = flip evalStateT True . whileM $ (liftIO $ httpNoBody request manager $> False)
  `catch` (\(_ :: HttpException) -> do
    -- get the flag (initial state is `True` two lines above)…
    firstFail <- get
    -- …and reset it so that it's not triggered anymore
    put False

    liftIO $ do
      when firstFail $ putStrLn "Waiting for server…"
      threadDelay 1_000_000
    pure True)

This works in theory… but not in practice:

1
2
3
4
5
6
7
8
9
10
11
12

• Couldn't match expected type ‘StateT Bool IO Bool’
                with actual type ‘IO Bool’
• In the second argument of ‘($)’, namely
    ‘(liftIO $ httpNoBody request manager $> False)
        `catch`
            (\ (_ :: HttpException)
            -> do firstFail <- get
                    put False
                    liftIO
                    $ do when firstFail $ putStrLn "Waiting for server…"
                            ....
                    ....)’

The snag here is that catch :: IO a -> (e -> IO a) -> IO a (the type is slightly simplified), so it must return an IO value. Our StateT Bool IO is a more specific type than IO, and there is no way to use it here. If we had a function like catch' :: MonadIO m => m a -> (e -> m a) -> m a and replaced catch with catch' in the code above, it would compile just fine.

I came up with a twist: leave the check in IO, but wrap it in a StateT. In this case, I can get the flag outside and use it inside the “pure” IO; it looks like this:

1
2
3
4
5
6
7
8
9
10

waitForAppearance' :: Manager -> Request -> IO ()
waitForAppearance' manager request = flip evalStateT True . whileM $ do
  firstFail <- get
  put False

  liftIO $ (httpNoBody request manager $> False)
    `catch` (\(_ :: HttpException) -> do
      when firstFail $ putStrLn "Waiting for server…"
      threadDelay 1_000_000
      pure True)

This code is here: https://github.com/eunikolsky/logdl/commit/e489a0733bf77e7c561c3dc79852abb8b21a5c79#diff-3249fc67937c53545d9b7ac99aac10dde985e5288505cfb6a4eff1e91bdad0d5R33.

This is an elegant solution because:

• it doesn’t require changes to whileM;
• it does use StateT to track when to print the message;
• and it works with catch.