I found mentions of this mentioned in an open cabal ticket and someone even made a git repo to explore it. I posted a question on the Nix discorse.

Basically, when running cabal test in a dev shell, started with nix develop, the tool hspec-discover wasn't found. At the same time the packages was installed

(ins)$ ghc-pkg list | rg hspec
    hspec-2.9.7
    hspec-core-2.9.7
    (hspec-discover-2.9.7)
    hspec-expectations-0.8.2

and it was on the $PATH

(ins)$ whereis hspec-discover
hspec-discover: /nix/store/vaq3gvak92whk5l169r06xrbkx6c0lqp-ghc-9.2.8-with-packages/bin/hspec-discover /nix/store/986bnyyhmi042kg4v6d918hli32lh9dw-hspec-discover-2.9.7/bin/hspec-discover

The solution, as the user julm pointed out, is to simply do what cabal tells you and run cabal update first.

The project's tests were set up in such a way that standalone tests and integration tests are mixed into the same test executable. As the integration tests need the just built service to be running they can't be run during nix build. However, the only way of preventing that, without making code changes, is to pass an argument to the test executable, --skip=<prefix>, and I believe that's not possible when using developPackage. It's not a big deal though, it's perfectly fine to run the tests separately using nix develop . command .... However, it turns out developPackage and the underlying machinery is smart enough to skip installing package required for testing when it's turned off (using dontCheck). This is the case also when returnShellEnv is true.

Luckily it's not too difficult to deal with it. I already had a variable isDevShell so I could simply reuse it and add the following expression to modifier

(if isDevShell then hl.doCheck else hl.dontCheck)

Browsing through the API documentation for Warp it wasn't too difficult to find the interesting pieces, and that Warp follows a fairly common pattern in Haskell libraries

• There's a function called runSettings that takes an argument of type Settings.
• The default settings are available in a variable called defaultSettings (not very surprising).

• There are several functions for modifying the settings and they all have the same shape

  setX :: X -> Settings -> Settings.
  

  which makes it easy to chain them together.

• The functions I'm interested in now are

  setOnException

  the default handler, defaultOnException, prints the exception to stdout using its Show instance

  setOnExceptionResponse

  the default responses are produced by defaultOnExceptionResponse and contain plain text response bodies

  setInstallShutdownHandler

  the default behaviour is to wait for all ongoing requests and then shut done

  setGracefulShutdownTimeout

  sets the number of seconds to wait for ongoing requests to finnish, the default is to wait indefinitely

In order to experiment with these I put together a small API using servant, app, with a main function using runSettings and stringing together a bunch of modifications to defaultSettings.

main :: IO ()
main = Log.withLogger $ \logger -> do
    Log.infoIO logger "starting the server"
    runSettings (mySettings logger defaultSettings) (app logger)
    Log.infoIO logger "stopped the server"
  where
    mySettings logger = myShutdownHandler logger . myOnException logger . myOnExceptionResponse

myOnException logs JSON objects (using the logging I've written about before, here and here). It decides wether to log or not using defaultShouldDisplayException, something I copied from defaultOnException.

myOnException :: Log.Logger -> Settings -> Settings
myOnException logger = setOnException handler
  where
    handler mr e = when (defaultShouldDisplayException e) $ case mr of
        Nothing -> Log.warnIO logger $ lm $ "exception: " <> T.pack (show e)
        Just _ -> do
            Log.warnIO logger $ lm $ "exception with request: " <> T.pack (show e)

myExceptionResponse responds with JSON objects. It's simpler than defaultOnExceptionResponse, but it suffices for my learning.

myOnExceptionResponse :: Settings -> Settings
myOnExceptionResponse = setOnExceptionResponse handler
  where
    handler _ =
        responseLBS
            H.internalServerError500
            [(H.hContentType, "application/json; charset=utf-8")]
            (encode $ object ["error" .= ("Something went wrong" :: String)])

Finally, myShutdownHandler installs a handler for SIGTERM that logs and then shuts down.

myShutdownHandler :: Log.Logger -> Settings -> Settings
myShutdownHandler logger = setInstallShutdownHandler shutdownHandler
  where
    shutdownAction = Log.infoIO logger "closing down"
    shutdownHandler closeSocket = void $ installHandler sigTERM (Catch $ shutdownAction >> closeSocket) Nothing

I really ought to have looked into this sooner, especially as it turns out that Warp offers all the knobs and dials I could wish for to control these aspects of its behaviour. The next step is to take this and put it to use in one of the services at $DAYJOB

I've written about that earlier in three posts:

1. A take on log messages
2. A take on logging
3. Logging with class

After reading about the uncaught exception handler in Serokell's article I've added the following snippet to all the services.

main :: IO ()
main = do
    ...
    originalHandler <- getUncaughtExceptionHandler
    setUncaughtExceptionHandler $ handle originalHandler . lastExceptionHandler logger
    ...

lastExceptionHandler :: Logger -> SomeException -> IO ()
lastExceptionHandler logger e = do
    fatalIO logger $ lm $ "uncaught exception: " <> displayException e

To make sure the platform we're running our services on is happy with a service it needs to handle SIGTERM, and when running it locally during development, e.g. for manual testing, it's nice if it also handles SIGINT.

The following snippet comes from a service that needs to make sure that every iteration of its processing is completed before shutting down, hence the IORef that's used to signal whether procession should continue or not.

main :: IO ()
main = do
    ...
    cont <- newIORef True
    void $ installHandler softwareTermination (Catch $ sigHandler logger cont) Nothing
    void $ installHandler keyboardSignal (Catch $ sigHandler logger cont) Nothing
    ...

sigHandler :: Logger -> IORef Bool -> IO ()
sigHandler logger cont = do
    infoIO logger "got a signal, shutting down"
    writeIORef cont False

Due to some details about how networking works in our platform it's currently not possible to use network-based probing. Instead we have to use files. There are two probes that are of interest

• A startup probe, existance of the file signals that the service has started as is about being processing.
• A progress probe, a timestamp signals the time the most recent iteration of processing finished¹.

I've written a little bit about the latter before in A little Haskell: epoch timestamp, but here I'm including both functions.

createPidFile :: FilePath -> IO ()
createPidFile fn = getProcessID >>= writeFile fn . show

writeTimestampFile :: MonadIO m => FilePath -> m ()
writeTimestampFile fn = liftIO $ do
    getPOSIXTime >>= (writeFile fn . show) . truncate @_ @Int64 . (* 1000)

First off I had to make sure the parser for Cabal was installed. The snippet for that looks like this¹

(use-package treesit
  :straight nil
  :ensure nil
  :commands (treesit-install-language-grammar)
  :init
  (setq treesit-language-source-alist
        '((cabal . ("https://gitlab.com/magus/tree-sitter-cabal.git")))))

With that in place the parser is installed using M-x treesit-install-language-grammar and choosing cabal.

After that I removed my configuration for haskell-mode and added the following snippet to get my own major mode into my setup.

(use-package my-cabal-mode
  :straight (:type git
             :repo "git@gitlab.com:magus/my-emacs-pkgs.git"
             :branch "main"
             :files (:defaults "my-cabal-mode/*el")))

The built-in elisp documentation actually has a section on writing a major mode with tree-sitter, so it was easy to get started. Setting up the font-locking took a bit of trial-and-error, but once I had comments looking the way I wanted it was easy to add to the setup. Oh, and yes, there's a section on font-locking with tree-sitter in the documentation too. At the moment it looks like this

(defvar cabal--treesit-font-lock-setting
  (treesit-font-lock-rules
   :feature 'comment
   :language 'cabal
   '((comment) @font-lock-comment-face)

   :feature 'cabal-version
   :language 'cabal
   '((cabal_version _) @font-lock-constant-face)

   :feature 'field-name
   :language 'cabal
   '((field_name) @font-lock-keyword-face)

   :feature 'section-name
   :language 'cabal
   '((section_name) @font-lock-variable-name-face))
  "Tree-sitter font-lock settings.")

;;;###autoload
(define-derived-mode my-cabal-mode fundamental-mode "My Cabal"
  "My mode for Cabal files"

  (when (treesit-ready-p 'cabal)
    (treesit-parser-create 'cabal)
    ;; set up treesit
    (setq-local treesit-font-lock-feature-list
                '((comment field-name section-name)
                  (cabal-version)
                  () ()))
    (setq-local treesit-font-lock-settings cabal--treesit-font-lock-setting)
    (treesit-major-mode-setup)))

;;;###autoload
(add-to-list 'auto-mode-alist '("\\.cabal\\'" . my-cabal-mode))

One of the reasons I want to experiment with tree-sitter is to use it for code navigation. My first attempt is to translate haskell-cabal-section-beginning (in haskell-mode, the source) to using tree-sitter. First a convenience function to recognise if a node is a section or not

(defun cabal--node-is-section-p (n)
  "Predicate to check if treesit node N is a Cabal section."
  (member (treesit-node-type n)
          '("benchmark" "common" "executable" "flag" "library" "test_suite")))

That makes it possible to use treesit-parent-until to traverse the nodes until hitting a section node

(defun cabal-goto-beginning-of-section ()
  "Go to the beginning of the current section."
  (interactive)
  (when-let* ((node-at-point (treesit-node-at (point)))
              (section-node (treesit-parent-until node-at-point #'cabal--node-is-section-p))
              (start-pos (treesit-node-start section-node)))
    (goto-char start-pos)))

And the companion function, to go to the end of a section is very similar

(defun cabal-goto-end-of-section ()
  "Go to the end of the current section."
  (interactive)
  (when-let* ((node-at-point (treesit-node-at (point)))
              (section-node (treesit-parent-until node-at-point #'cabal--node-is-section-p))
              (end-pos (treesit-node-end section-node)))
    (goto-char end-pos)))

First off I want a monad for the logging itself. It's just a collection of functions taking a LogMsg and returning unit (in a monad).

class Monad m => LoggerActions m where
    debug :: LogMsg -> m ()
    info :: LogMsg -> m ()
    warn :: LogMsg -> m ()
    err :: LogMsg -> m ()
    fatal :: LogMsg -> m ()

In order to provide a default implementation I also need a way to extract the logger itself.

class Monad m => HasLogger m where
    getLogger :: m Logger

Using the two typeclasses above it's now possible to define a type with an implementation of LoggerActions that is usable with deriving via.

newtype StdLoggerActions m a = MkStdZLA (m a)
    deriving (Functor, Applicative, Monad, MonadIO, HasLogger)

And its implementattion of LoggerActions looks like this:

instance (HasLogger m, MonadIO m) => LoggerActions (StdLoggerActions m) where
    debug msg = getLogger >>= flip debugIO msg
    info msg = getLogger >>= flip infoIO msg
    warn msg = getLogger >>= flip warnIO msg
    err msg = getLogger >>= flip errIO msg
    fatal msg = getLogger >>= flip fatalIO msg

Using the definitions above is fairly straight forward. First a type the derives its implementaiton of LoggerActions from StdLoggerActions.

newtype EnvT a = EnvT {runEnvT :: ReaderT Logger IO a}
    deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader Logger)
    deriving (LoggerActions) via (StdLoggerActions EnvT)

In order for it to work, and compile, it needs an implementation of HasLogger too.

instance HasLogger EnvT where
    getLogger = ask

All that's left is a function using a constraint on LoggerActions (doStuff) and a main function creating a logger, constructing an EnvT, and then running doStuff in it.

doStuff :: LoggerActions m => m ()
doStuff = do
    debug "a log line"
    info $ "another log line" #+ ["extras" .= (42 :: Int)]

main :: IO ()
main = withLogger $ \logger ->
    runReaderT (runEnvT doStuff) logger

The logger will be a wrapper around fast-logger's FastLogger, even though that's not really visible.

newtype Logger = Logger (LogMsg -> IO ())

It's nature as a wrapper makes it natural to follow the API of fast-logger, with some calls to liftIO added.

newLogger :: MonadIO m => m (Logger, m ())
newLogger = liftIO $ do
    (fastLogger, cleanUp) <- newFastLogger $ LogStdout defaultBufSize
    pure (Logger (fastLogger . toLogStr @LogMsg), liftIO cleanUp)

The implementation of withLogger is pretty much a copy of what I found in fast-logger, just adapted to the newLogger above.

withLogger :: (MonadMask m, MonadIO m) => (Logger -> m ()) -> m ()
withLogger go = bracket newLogger snd (go . fst)

All logging functions will follow the same pattern so it's easy to break out the common parts.

logIO :: MonadIO m => Text -> Logger -> LogMsg -> m ()
logIO lvl (Logger ls) msg = do
    t <- formatTime defaultTimeLocale "%y-%m-%dT%H:%M:%S%03QZ" <$> liftIO getCurrentTime
    let bmsg = "" :# [ "correlation-id" .= ("no-correlation-id" :: Text)
                     , "timestamp" .= t
                     , "level" .= lvl
                     ]
    liftIO $ ls $ bmsg <> msg

With that in place the logging functions become very short and sweet.

debugIO, infoIO, warnIO, errIO, fatalIO :: MonadIO m => Logger -> LogMsg -> m ()
debugIO = logIO "debug"
infoIO = logIO "info"
warnIO = logIO "warn"
errIO = logIO "error"
fatalIO = logIO "fatal"

A very simple example showing how it could be used would be something like this

main :: IO ()
main = withLogger $ \logger -> do
    debugIO logger "a log line"
    infoIO logger $ "another log line" #+ ["extras" .= (42 :: Int)]

I decided that a log message must always contain the text describing the event. It's the one thing that's sure to be known at the point where the developer writes the code to log an event. All the other mandatory parts can, and probably should as far as possible, be added by the logging library itself. So I ended up with this type.

data LogMsg = Text :# [Pair]
    deriving (Eq, Show)

It should however be easy to add custom parts at the point of logging, so I added an operator for that.

(#+) :: LogMsg -> [Pair] -> LogMsg
(#+) (msg :# ps0) ps1 = msg :# (ps0 <> ps1)

The ordering is important, i.e. ps0 <> ps1, as aeson's object function will take the last value for a field and I want to be able to give keys in a log message new values by overwriting them later on.

The previous logging code used fast-logger and it had worked really well so I decided to stick with it. Making LogMsg and instance of ToLogStr is key, and as the rules require logging of JSON objects it also needs to be an instance of ToJSON.

instance ToJSON LogMsg where
    toJSON (msg :# ps) = object $ ps <> ["message" .= msg]

instance ToLogStr LogMsg where
    toLogStr msg = toLogStr (encode msg) <> "\n"

It's common to just want to log a single string and nothing else, so it's handy if LogMsg is an instance of IsString.

instance IsString LogMsg where
    fromString msg = pack msg :# []

When writing the previous logging code I'd regularly felt pain from the lack of a nice way to combine log messages. With the definition of LogMsg above it's not difficult to come up with reasonable instances for both Semigroup and Monoid.

instance Semigroup LogMsg where
    "" :# ps0 <> msg1 :# ps1 = msg1 :# (ps0 <> ps1)
    msg0 :# ps0 <> "" :# ps1 = msg0 :# (ps0 <> ps1)
    msg0 :# ps0 <> msg1 :# ps1 = (msg0 <> " - " <> msg1) :# (ps0 <> ps1)

instance Monoid LogMsg where
    mempty = ""

What's missing above is the automatic handling of the remaining fields. I'll try to get back to that part soon. For now I'll just say that the log message API above made the implementation nice and straight forward.

The code for making film ratings into a Monoid, when translated to the UK, would look something like this:

{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module DeriveMonoid where

newtype Supremum a = MkSup a
    deriving stock (Bounded, Eq, Ord)
    deriving newtype (Show)

instance Ord a => Semigroup (Supremum a) where
    (<>) = max

instance (Bounded a, Ord a) => Monoid (Supremum a) where
    mempty = minBound

data FilmClassification
    = Universal
    | ParentalGuidance
    | Suitable12
    | Suitable15
    | Adults
    | Restricted18
    deriving stock (Bounded, Eq, Ord)
    deriving (Monoid, Semigroup) via (Supremum FilmClassification)

First let's write up a silly class for writing to stdout, a single operation will do.

class Monad m => StdoutWriter m where
    writeStdoutLn :: String -> m ()

Then we'll need a type to attach the implementation to.

newtype SimpleStdoutWriter m a = SimpleStdoutWriter (m a)
    deriving (Functor, Applicative, Monad, MonadIO)

and of course an implementation

instance MonadIO m => StdoutWriter (SimpleStdoutWriter m) where
    writeStdoutLn = liftIO . putStrLn

Now let's create an app environment based on ReaderT and use deriving via to give it an implementation of StdoutWriter via SimpleStdoutWriter.

newtype AppEnv a = AppEnv {unAppEnv :: ReaderT Int IO a}
    deriving
        ( Functor
        , Applicative
        , Monad
        , MonadIO
        , MonadReader Int
        )
    deriving (StdoutWriter) via (SimpleStdoutWriter AppEnv)

Then a quick test to show that it actually works.

λ> runReaderT (unAppEnv $ writeStdoutLn "hello, world!") 0
hello, world!

It's fairly easy to get the desired behaviour but Alternative of IO is based on exceptions which doesn't strike me as a good idea unless one is using IO directly. That is fine in a smallish application, but in my case it makes sense to use tagless style (or ReaderT pattern) so I'll skip exploring this option completely.

There's an instance of Alternative for Either e in version 0.5 of transformers. It's deprecated and it's gone in newer versions of the library as one really should use Except or ExceptT instead. Even if I don't think it's where I want to end up, it's not an altogether bad place to start.

Now let's define a function using liftA2 (<|>) to make it easy to see what the behaviour is

fallBack ::
    Applicative m =>
    m (Either String res) ->
    m (Either String res) ->
    m (Either String res)
fallBack = liftA2 (<|>)

λ> loadFromDisk "bad key" `fallBack` loadFromWeb "good key"
local: bad key
web: good key
Right 8

λ> loadFromDisk "bad key" `fallBack` loadFromWeb "bad key"
local: bad key
web: bad key
Left "no such remote key: bad key"

The first example shows that it falls back to loading form the web, and the second one shows that it's only the last failure that survives. The latter part, that only the last failure survives, isn't ideal but I think I can live with that. If I were interested in collecting all failures I would reach for Validation from validation-selective (there's one in validation that should work too).

So far so good, but the next example shows a behaviour I don't want

λ> loadFromDisk "good key" `fallBack` loadFromWeb "good key"
local: good key
web: good key
Right 8

or to make it even more explicit

λ> loadFromDisk "good key" `fallBack` undefined
local: good key
*** Exception: Prelude.undefined
CallStack (from HasCallStack):
  error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err
  undefined, called at <interactive>:451:36 in interactive:Ghci4

There's no short-circuiting!¹

The behaviour I want is of course that if the first action is successful, then the second action shouldn't take place at all.

It looks like either <|> is strict in its second argument, or maybe it's liftA2 that forces it. I've not bothered digging into the details, it's enough to observe it to realise that this approach isn't good enough.

Fixing the lack of short-circuiting the evaluation after the first success isn't too difficult to do manually. Something like this does it

fallBack ::
    Monad m =>
    m (Either String a) ->
    m (Either String a) ->
    m (Either String a)
fallBack first other = do
    first >>= \case
        r@(Right _) -> pure r
        r@(Left _) -> (r <|>) <$> other

It does indeed show the behaviour I want

λ> loadFromDisk "bad key" `fallBack` loadFromWeb "good key"
local: bad key
web: good key
Right 8

λ> loadFromDisk "bad key" `fallBack` loadFromWeb "bad key"
local: bad key
web: bad key
Left "no such remote key: bad key"

λ> loadFromDisk "good key" `fallBack` undefined
local: good key
Right 8

Excellent! And to switch over to use Validation one just have to switch constructors, Right becomes Success and Left becomes Failure. Though collecting the failures by concatenating strings isn't the best idea of course. Switching to some other Monoid (that's the constraint on the failure type) isn't too difficult.

fallBack ::
    (Monad m, Monoid e) =>
    m (Validation e a) ->
    m (Validation e a) ->
    m (Validation e a)
fallBack first other = do
    first >>= \case
        r@(Success _) -> pure r
        r@(Failure _) -> (r <|>) <$> other

After writing the fallBack function I still wanted to explore other solutions. There's almost always something more out there in the Haskell eco system, right? So I asked in the #haskell-beginners channel on the Functional Programming Slack. The way I asked the question resulted in answers that iterates over a list of actions and cutting at the first success.

The first suggestion had me a little confused at first, but once I re-organised the helper function a little it made more sense to me.

mFromRight :: MonadPlus m => m (Either err res) -> m res
mFromRight = (either (const mzero) return =<<)

To use it put the actions in a list, map the helper above, and finally run asum on it all². I think it makes it a little clearer what happens if it's rewritten like this.

firstRightM :: MonadPlus m => [m (Either err res)] -> m res
firstRightM = asum . fmap go
  where
    go m = m >>= either (const mzero) return

λ> firstRightM [loadFromDisk "bad key", loadFromWeb "good key"]
local: bad key
web: good key
8

λ> firstRightM [loadFromDisk "good key", undefined]
local: good key
8

So far so good, but I left out the case where both fail, because that's sort of the fly in the ointment here

λ> firstRightM [loadFromDisk "bad key", loadFromWeb "bad key"]
local: bad key
web: bad key
*** Exception: user error (mzero)

It's not nice to be back to deal with exceptions, but it's possible to recover, e.g. by appending <|> pure 0.

λ> firstRightM [loadFromDisk "bad key", loadFromWeb "bad key"] <|> pure 0
local: bad key
web: bad key
0

However that removes the ability to deal with the situation where all actions fail. Not nice! Add to that the difficulty of coming up with a good MonadPlus instance for an application monad; one basically have to resort to the same thing as for IO, i.e. to throw an exception. Also not nice!

This was another suggestion from the Slack channel, and it is the one I like the most. Again it was suggested as a way to stop at the first successful action in a list of actions.

firstRightM ::
    (Foldable t, Functor t, Monad m, Monoid err) =>
    t (m (Either err res)) ->
    m (Either err res)
firstRightM = runExceptT . asum . fmap ExceptT

Which can be used similarly to the previous one. It's also easy to write a variant of fallBack for it.

fallBack ::
    (Monad m, Monoid err) =>
    m (Either err res) ->
    m (Either err res) ->
    m (Either err res)
fallBack first other = runExceptT $ ExceptT first <|> ExceptT other

λ> loadFromDisk "bad key" `fallBack` loadFromWeb "good key"
local: bad key
web: good key
Right 8

λ> loadFromDisk "good key" `fallBack` undefined
local: good key
Right 8

λ> loadFromDisk "bad key" `fallBack` loadFromWeb "bad key"
local: bad key
web: bad key
Left "no such local key: bad keyno such remote key: bad key"

Yay! This solution has the short-circuiting behaviour I want, as well as collecting all errors on failure.

I'm still a little disappointed that liftA2 (<|>) isn't short-circuiting as I still think it's the easiest of the approaches. However, it's a problem that one has to rely on a deprecated instance of Alternative for Either String, but switching to use Validation would be only a minor change.

Manually writing the fallBack function, as I did in the second attempt, results in very explicit code which is nice as it often reduces the cognitive load for the reader. It's a contender, but using the deprecated Alternative instance is problematic and introducing Validition, an arguably not very common type, takes away a little of the appeal.

In the end I prefer the fourth attempt. It behaves exactly like I want and even though ExpectT lives in transformers I feel that it (I pull it in via mtl) is in such wide use that most Haskell programmers will be familiar with it.

One final thing to add is that the documentation of Validation is an excellent inspiration when it comes to the behaviour of its instances. I wish that the documentation of other packages, in particular commonly used ones like base, transformers, and mtl, would be more like it.

The first approach I came up with was to traverse the sub-objects and apply a function that adds the image key.

setImage :: Value -> Value
setImage y = y & members %~ setImg
  where
    setImg o =
        o
            & _Object . at "image"
            ?~ String (o ^. key "x-image" . _String <> ":latest")

It did make me wonder if this kind of problem, setting a value based on another value, isn't so common that there's a nicer solution to it. Perhaps coded up in a combinator that isn't mentioned in Optics By Example (or mabye I've forgot it was mentioned). That lead me to ask around a bit, which leads to approach two.

Arguably there isn't much difference, it's still traversing the sub-objects and applying a function. The function makes use of view being run in a monad and ASetter being defined with Identity (a monad).

setImage' :: Value -> Value
setImage' y =
    y
        & members . _Object
        %~ (set (at "image") . (_Just . _String %~ (<> ":latest")) =<< view (at "x-image"))

I haven't made up my mind on whether I like this better than the first. It's disappointingly similar to the first one.

Then I it might be nice to split the fetching of x-image values from the addition of image key/value pairs. By extracting with an index it's possible to keep track of what sub-object each x-image value comes from. Then two steps can be combined using foldl.

setImage'' :: Value -> Value
setImage'' y = foldl setOne y vals
  where
    vals = y ^@.. members <. key "x-image" . _String
    setOne y' (objKey, value) =
        y'
            & key objKey . _Object . at "image"
            ?~ String (value <> ":latest")

I'm not convinced though. I guess I'm still holding out for a brilliant combinator that fits my problem perfectly.

Please point me to "the perfect solution" if you have one, or if you just have some general tips on optics that would make my code clearer, or shorter, or more elegant, or maybe just more lens-y.

My hope is that using HMock will remove the need for creating a bunch of test implementations for the various custom monads for effects¹ in the projects, thereby reducing the amount of test code overall. I also suspect that it will make the tests clearer and easier to read, as the behaviour of the mocks are closer to the tests using the mocks.

I opted to use barbies-th to save on the typing a bit. Defining a simple type holding a name and an age can then look like this

declareBareB
  [d|
   data Person = Person {name :: Text, age :: Int}
  |]

deriving instance Show (Person Covered Identity)
deriving instance Show (Person Covered Maybe)
deriving instance Show (Person Covered (Either Text))

The two functions from the Barbies module documentation, addDefaults and check, can then be written like this

addDefaults :: Person Covered Maybe -> Person Covered Identity -> Person Covered Identity
addDefaults = bzipWith trans
  where
    trans m d = maybe d pure m

check :: Person Covered (Either Text) -> Either [Text] (Person Covered Identity)
check pe = case btraverse (either (const Nothing) (Just . Identity)) pe of
  Just pin -> Right pin
  Nothing -> Left $ bfoldMap (either (: []) (const [])) pe

I found it straight forward to define some instances and play with those functions a bit.

The bit that wasn't immediately obvious to me was how to use aeson to parse into a type like Person Covered (Either Text).

First off I needed some data to test things out with.

bs0, bs1 :: BSL.ByteString
bs0 = "{\"name\": \"the name\", \"age\": 17}"
bs1 = "{\"name\": \"the name\", \"age\": true}"

To keep things simple I took baby steps, first I tried parsing into Person Covered Identity. It turns out that the FromJSON instance from that doesn't need much thought at all. (It's a bit of a pain to have to specify types in GHCi all the time, so I'm throwing in a specialised decoding function for each type too.)

instance FromJSON (Person Covered Identity) where
  parseJSON = withObject "Person" $
    \o -> Person <$> o .: "name"
      <*> o .: "age"

decodePI :: BSL.ByteString -> Maybe (Person Covered Identity)
decodePI = decode

Trying it out on the test data gives the expected results

λ> let i0 = decodePI bs0
λ> i0
Just (Person {name = Identity "the name", age = Identity 17})
λ> let i1 = decodePI bs1
λ> i1
Nothing

So far so good! Moving onto Person Covered Maybe. I spent some time trying to use the combinators in Data.Aeson for dealing with parser failures, but in the end I had to resort to using <|> from Alternative.

instance FromJSON (Person Covered Maybe) where
  parseJSON = withObject "Person" $
    \o -> Person <$> (o .: "name" <|> pure Nothing)
      <*> (o .: "age" <|> pure Nothing)

decodePM :: BSL.ByteString -> Maybe (Person Covered Maybe)
decodePM = decode

Trying that out I saw exactly the behaviour I expected, i.e. that parsing won't fail. (Well, at least not as long as it's a valid JSON object to being with.)

λ> let m0 = decodePM bs0
λ> m0
Just (Person {name = Just "the name", age = Just 17})
λ> let m1 = decodePM bs1
λ> m1
Just (Person {name = Just "the name", age = Nothing})

With that done I found that the instance for Person Covered (Either Text) followed quite naturally. I had to spend a little time on getting the types right to parse the fields properly. Somewhat disappointingly I didn't get type errors when the behaviour of the code turned out to be wrong. I'm gussing aeson's Parser was a little too willing to give me parser failures. Anyway, I ended up with this instance

instance FromJSON (Person Covered (Either Text)) where
  parseJSON = withObject "Person" $
    \o -> Person <$> ((Right <$> o .: "name") <|> pure (Left "A name is most needed"))
      <*> ((Right <$> o .: "age") <|> pure (Left "An integer age is needed"))

decodePE :: BSL.ByteString -> Maybe (Person Covered (Either Text))
decodePE = decode

That does exhibit the behaviour I want

λ> let e0 = decodePE bs0
λ> e0
Just (Person {name = Right "the name", age = Right 17})
λ> let e1 = decodePE bs1
λ> e1
Just (Person {name = Right "the name", age = Left "An integer age is needed"})

I think everyone will agree that the FromJSON instances are increasingly messy. I think that can be fixed by putting some thought into what a more pleasing API should look like.

I'd also like to mix in validation beyond what aeson offers out-of-the-box, which really only is "is the field present?" and "does the value have the correct type?". For instance, Once we know there is a field called age, and that it's an Int, then we might want to make sure it's non-negitive, or that the person is at least 18. I'm guessing that wouldn't be too difficult.

Finally, I'd love to see examples of using HKDs for parsing/validation in the wild. It's probably easiest to reach me at @magthe@mastodon.technology.

I was using unliftio in my service, and as long as I based my monad stack only on ReaderT that worked fine. I even got the MonadUnliftIO instance for free through automatic deriving. ExceptT isn't a stateless monad though, so using unliftio is out of the question, instead I had to switch to MonadBaseControl and the packages that work with it. Defining and instance of MonadBaseControl looked a bit daunting, but luckily Handler has an instance of it that I used as inspiration.

First off MonadBaseControl requires the type to also be an instance of MonadBase. There's an explicit implementation for Handler, but I found that it can be derived automatically, so I took the lazy route.

The instance of MonadBaseControl for AppM ended up looking like this

instance MonadBaseControl IO AppM where
  type StM AppM a = Either ServerError a

  liftBaseWith f = AppM (liftBaseWith (\g -> f (g . unAppM)))
  restoreM = AppM . restoreM

I can't claim to really understand what's going on in that definition, but I have Alexis King's article on Demystifying MonadBaseControl on my list of things to read.

When capturing the ID it's no longer possible to use a simple Map Int Text for the state, because I don't actually have the ID until I have an HTTP response. However, the ID is playing an important role in the constructing of a sequence of actions. The trick is to use Var Int v instead of an ordinary Int. As I understand it, and I believe that's a good enough understanding to make use of Hedgehog possible, is that this way the ID is an opaque blob in the construction phase, and it's turned into a concrete value during execution. When in the opaque state it implements enough type classes to be useful for my purposes.

newtype State (v :: * -> *)= State (M.Map (Var Int v) Text)
  deriving (Eq, Show)

When taking a closer look at the Callback type not all the callbacks will get the state in the same form, opaque or concrete, and one of them, Update actually receives the state in both states depending on the phase of execution. This has the most impact on the add user action. To deal with it there's a need to rearrange the code a bit, to be specific, commandExecute can no longer return a tuple of both the ID and the status of the HTTP response because the update function can't reach into the tuple, which it needs to update the state.

That means the commandExecute function will have to do tests too. It is nice to keep all tests in the callbacks, but by sticking a MonadTest m constraint on the commandExecute it turns into a nice solution anyway.

addUser :: (MonadGen n, MonadIO m, MonadTest m) => Command n m State
addUser = Command gen exec [ Update u
                           ]
  where
    gen _ = Just $ AddUser <$> Gen.text (Range.linear 0 42) Gen.alpha

    exec (AddUser n) = do
      (s, ui) <- liftIO $ do
        mgr <- newManager defaultManagerSettings
        addReq <- parseRequest "POST http://localhost:3000/users"
        let addReq' = addReq { requestBody = RequestBodyLBS (encode $ User 0 n)}
        addResp <- httpLbs addReq' mgr
        let user = decode (responseBody addResp) :: Maybe User
        return (responseStatus addResp, user)
      status201 === s
      assert $ isJust ui
      (userName <$> ui) === Just n
      return $ userId $ fromJust ui

    u (State m) (AddUser n) o = State (M.insert o n m)

I found that once I'd come around to folding the Ensure callback into the commandExecute function the rest fell out from the types.

The other actions, deleting a user and getting a user, required only minor changes and the changes were rather similar in both cases.

Not the type for the action needs to take a Var Int v instead of just a plain Int.

newtype DeleteUser (v :: * -> *) = DeleteUser (Var Int v)
  deriving (Eq, Show)

Which in turn affect the implementation of HTraversable

instance HTraversable DeleteUser where
  htraverse f (DeleteUser vi) = DeleteUser <$> htraverse f vi

Then the changes to the Command mostly comprise use of concrete in places where the real ID is needed.

deleteUser :: (MonadGen n, MonadIO m) => Command n m State
deleteUser = Command gen exec [ Update u
                              , Require r
                              , Ensure e
                              ]
  where
    gen (State m) = case M.keys m of
      [] -> Nothing
      ks -> Just $ DeleteUser <$> Gen.element ks

    exec (DeleteUser vi) = liftIO $ do
      mgr <- newManager defaultManagerSettings
      delReq <- parseRequest $ "DELETE http://localhost:3000/users/" ++ show (concrete vi)
      delResp <- httpNoBody delReq mgr
      return $ responseStatus delResp

    u (State m) (DeleteUser i) _ = State $ M.delete i m

    r (State m) (DeleteUser i) = i `elem` M.keys m

    e _ _ (DeleteUser _) r = r === status200

This post concludes my playing around with state machines in Hedgehog for this time. I certainly hope I find the time to put it to use on some larger API soon. In particular I'd love to put it to use at work; I think it'd be an excellent addition to the integration tests we currently have.

The service is split into two parts, one web server using scotty, and streaming data processing using conduit. Persistent storage is provided by a PostgreSQL database. The general idea is that events are picked up from the database, acted upon, which in turn results in other events which written to the database. Those are then picked up and round and round we go. The web service accepts requests, turns them into events and writes the to the database.

Hopefully this crude diagram clarifies it somewhat.

There are a few things that might need some explanation

• In the past we've wanted to have the option to use multiple external SMS services at the same time. One is randomly chosen as the request comes in. There's also a possibility to configure the frequency for each external service.

  Picker implements the random picking and I've written about that earlier in Choosing a conduit randomly.

  Success and fail are dummy senders. They don't actually send anything, and the former succeeds at it while the latter fails. I found them useful for manual testing.

• Successfully sending off a request to an external SMS service, getting status 200 back, doesn't actually mean that the SMS has been sent, or even that it ever will be. Due to the nature of SMS messaging there are no guarantees of timeliness at all. Since we are interested in finding out whether an SMS actually is sent a delayed action is scheduled, which will fetch the status of a sent SMS after a certain time (currently 2 minutes). If an SMS hasn't been sent after that time it might as well never be – it's too slow for our end-users.

  This is what report-fetcher and fetcher-func do.

• The queue sink and queue src are actually sourceTQueue and sinkTQueue. Splitting the stream like that makes it trivial to push in events by using writeTQueue.
• I use sequenceConduits in order to send a single event to multiple =Conduit=s and then combine all their results back into a single stream. The ease with which this can be done in conduit is one of the main reasons why I choose to use it.²

I started out writing everything based on a type like ReaderT <my cfg type> IO and using liftIO for effects that needed lifting. This worked nicely while I was setting up the basic structure of the service, but as soon as I hooked in the database I really wanted to do some testing also of the effectful code.

After reading Introduction to Tagless Final and The ReaderT Design Patter, playing a bit with both approaches, and writing Tagless final and Scotty and The ReaderT design pattern or tagless final?, I finally chose to go down the route of tagless final. There's no strong reason for that decision, maybe it was just because I read about it first and found it very easy to move in that direction in small steps.

There's a split between property tests and unit tests:

• Data types, their monad instances (like JSON (de-)serialisation), pure functions and a few effects are tested using properties. I'm using QuickCheck for that. I've since looked a little closer at hedgehog and if I were to do a major overhaul of the property tests I might be tempted to rewrite them using that library instead.
• Most of the =Conduit=s are tested using HUnit.

The service will be run in a container and we try to follow the 12-factor app rules, where the third one says that configuration should be stored in the environment. All previous Haskell projects I've worked on have been command line tools were configuration is done (mostly) using command line argument. For that I usually use optparse-applicative, but it's not applicable in this setting.

After a bit of searching on hackage I settled on etc. It turned out to be nice an easy to work with. The configuration is written in JSON and only specifies environment variables. It's then embedded in the executable using file-embed. The only thing I miss is a ToJSON instance for Config – we've found it quite useful to log the active configuration when starting a service and that log entry would become a bit nicer if the message was JSON rather than the (somewhat difficult to read) string that Config's Show instance produces.

There are two requirements we have when it comes to logging

1. All log entries tied to a request should have a correlation ID.
2. Log requests and responses

I've written about correlation ID before, Using a configuration in Scotty.

Logging requests and responses is an area where I'm not very happy with scotty. It feels natural to solve it using middleware (i.e. using middleware) but the representation, especially of responses, is a bit complicated so for the time being I've skipped logging the body of both. I'd be most interested to hear of libraries that could make that easier.

The data stream processing depends heavily on being able to pick up when new events are written to the database. Especially when there are more than one instance running (we usually have at least two instance running in the production environment). To get that working I've used postgresql-simple's support for LISTEN and NOTIFY via the function getNotification.

When I wrote about this earlier, Conduit and PostgreSQL I got some really good feedback that made my solution more robust.

Some things in Haskell feel almost like cheating. The light-weight threading makes me confident that a forkIO followed by a threadDelay (or in my case, the ones from unliftio) will suffice.

The first issue I run into is

━━━ Main ━━━
  ✗ sequential failed after 18 tests and 1 shrink.

        ┏━━ tst/test-01.hs ━━━
     89 ┃ getUser :: (MonadGen n, MonadIO m) => Command n m State
     90 ┃ getUser = Command gen exec [ Require r
     91 ┃                            , Ensure e
     92 ┃                            ]
     93 ┃   where
     94 ┃     gen (State m) = case M.keys m of
     95 ┃       [] -> Nothing
     96 ┃       ks -> Just $ GetUser <$> Gen.element ks
     97 ┃
     98 ┃     exec (GetUser i) = liftIO $ do
     99 ┃       mgr <- newManager defaultManagerSettings
    100 ┃       getReq <- parseRequest $ "GET http://localhost:3000/users/" ++ show i
    101 ┃       getResp <- httpLbs getReq mgr
    102 ┃       let us = decode $ responseBody getResp :: Maybe [User]
    103 ┃       return (status200 == responseStatus getResp, us)
    104 ┃
    105 ┃     r (State m) (GetUser i) = i `elem` M.keys m
    106 ┃
    107 ┃     e _ _ (GetUser _) (r, us) = do
    108 ┃       r === True
    109 ┃       assert $ isJust us
    110 ┃       (length <$> us) === Just 1
        ┃       ^^^^^^^^^^^^^^^^^^^^^^^^^^
        ┃       │ Failed (- lhs =/= + rhs)
        ┃       │ - Just 0
        ┃       │ + Just 1

        ┏━━ tst/test-01.hs ━━━
    118 ┃ prop_seq :: Property
    119 ┃ prop_seq = property $ do
    120 ┃   actions <- forAll $ Gen.sequential (Range.linear 1 10) initialState [addUser, deleteUser, getUser]
        ┃   │ Var 0 = AddUser ""
        ┃   │ Var 1 = GetUser 1
    121 ┃   resetWS
    122 ┃   executeSequential initialState actions

    This failure can be reproduced by running:
    > recheck (Size 17) (Seed 2158538972777046104 (-1442908127347265675)) sequential

  ✗ 1 failed.

It's easy to verify this using httpie:

$ http -p b POST :3000/users userId:=0 "userName="
{
    "userId": 0,
    "userName": ""
}
$ http -p b GET :3000/users/1
[]

It's clear that my assumption that User ID starts at 1 is wrong. Luckily fixing that isn't too difficult. Instead of defining the update function for addUser as

u (State m) (AddUser n) _o = State $ M.insert k n m
  where
    k = succ $ foldl max 0 (M.keys m)

I define it as

u (State m) (AddUser n) _o = State $ M.insert k n m
  where
    k = case M.keys m of
      [] -> 0
      ks -> succ $ foldl max 0 ks

The complete code at this point can be found here.

With that fix in place another issue with the model shows up

━━━ Main ━━━
  ✗ sequential failed after 74 tests and 2 shrinks.

        ┏━━ tst/test-01.hs ━━━
     91 ┃ getUser :: (MonadGen n, MonadIO m) => Command n m State
     92 ┃ getUser = Command gen exec [ Require r
     93 ┃                            , Ensure e
     94 ┃                            ]
     95 ┃   where
     96 ┃     gen (State m) = case M.keys m of
     97 ┃       [] -> Nothing
     98 ┃       ks -> Just $ GetUser <$> Gen.element ks
     99 ┃
    100 ┃     exec (GetUser i) = liftIO $ do
    101 ┃       mgr <- newManager defaultManagerSettings
    102 ┃       getReq <- parseRequest $ "GET http://localhost:3000/users/" ++ show i
    103 ┃       getResp <- httpLbs getReq mgr
    104 ┃       let us = decode $ responseBody getResp :: Maybe [User]
    105 ┃       return (status200 == responseStatus getResp, us)
    106 ┃
    107 ┃     r (State m) (GetUser i) = i `elem` M.keys m
    108 ┃
    109 ┃     e _ _ (GetUser _) (r, us) = do
    110 ┃       r === True
    111 ┃       assert $ isJust us
    112 ┃       (length <$> us) === Just 1
        ┃       ^^^^^^^^^^^^^^^^^^^^^^^^^^
        ┃       │ Failed (- lhs =/= + rhs)
        ┃       │ - Just 0
        ┃       │ + Just 1

        ┏━━ tst/test-01.hs ━━━
    120 ┃ prop_seq :: Property
    121 ┃ prop_seq = property $ do
    122 ┃   actions <- forAll $ Gen.sequential (Range.linear 1 10) initialState [addUser, deleteUser, getUser]
        ┃   │ Var 0 = AddUser ""
        ┃   │ Var 1 = DeleteUser 0
        ┃   │ Var 2 = AddUser ""
        ┃   │ Var 3 = GetUser 0
    123 ┃   resetWS
    124 ┃   executeSequential initialState actions

    This failure can be reproduced by running:
    > recheck (Size 73) (Seed 3813043122711576923 (-444438259649958339)) sequential

  ✗ 1 failed.

Again, verifying this using httpie shows what the issue is

$ http -p b POST :3000/users userId:=0 "userName="
{
    "userId": 0,
    "userName": ""
}
$ http -p b DELETE :3000/users/0
$ http -p b POST :3000/users userId:=0 "userName="
{
    "userId": 1,
    "userName": ""
}
$ http -p b GET :3000/users/0
[]

In other words, the model assumes that the 0 User ID get's re-used.

To fix this I need a bigger change. The central bit is that the state is changed to keep track of the index more explicitly. That is, it changes from

newtype State (v :: * -> *)= State (M.Map Int Text)
  deriving (Eq, Show)

to

data State (v :: * -> *)= State Int (M.Map Int Text)
  deriving (Eq, Show)

That change does, quite obviously, require a bunch of other changes in the other functions dealing with the state. The complete file can be viewed here.

After this the tests pass, so all is good in the world, right?

In the test I defined the property over rather short sequences of commands. What happens if I increase the (maximum) length of the sequences a bit? Instead using Range.linear 1 10 I'll use Range.linear 1 1000. Well, besides taking slightly longer to run I get another sequence of commands that triggers an issue:

━━━ Main ━━━
  ✗ sequential failed after 13 tests and 29 shrinks.

        ┏━━ tst/test-01.hs ━━━
     87 ┃ getUser :: (MonadGen n, MonadIO m) => Command n m State
     88 ┃ getUser = Command gen exec [ Require r
     89 ┃                            , Ensure e
     90 ┃                            ]
     91 ┃   where
     92 ┃     gen (State _ m) = case M.keys m of
     93 ┃       [] -> Nothing
     94 ┃       ks -> Just $ GetUser <$> Gen.element ks
     95 ┃
     96 ┃     exec (GetUser i) = liftIO $ do
     97 ┃       mgr <- newManager defaultManagerSettings
     98 ┃       getReq <- parseRequest $ "GET http://localhost:3000/users/" ++ show i
     99 ┃       getResp <- httpLbs getReq mgr
    100 ┃       let us = decode $ responseBody getResp :: Maybe [User]
    101 ┃       return (status200 == responseStatus getResp, us)
    102 ┃
    103 ┃     r (State _ m) (GetUser i) = i `elem` M.keys m
    104 ┃
    105 ┃     e _ _ (GetUser _) (r, us) = do
    106 ┃       r === True
    107 ┃       assert $ isJust us
    108 ┃       (length <$> us) === Just 1
        ┃       ^^^^^^^^^^^^^^^^^^^^^^^^^^
        ┃       │ Failed (- lhs =/= + rhs)
        ┃       │ - Just 0
        ┃       │ + Just 1

        ┏━━ tst/test-01.hs ━━━
    116 ┃ prop_seq :: Property
    117 ┃ prop_seq = property $ do
    118 ┃   actions <- forAll $ Gen.sequential (Range.linear 1 1000) initialState [addUser, deleteUser, getUser]
        ┃   │ Var 0 = AddUser ""
        ┃   │ Var 2 = AddUser ""
        ┃   │ Var 5 = AddUser ""
        ┃   │ Var 7 = AddUser ""
        ┃   │ Var 9 = AddUser ""
        ┃   │ Var 11 = AddUser ""
        ┃   │ Var 20 = AddUser ""
        ┃   │ Var 28 = AddUser ""
        ┃   │ Var 30 = AddUser ""
        ┃   │ Var 32 = AddUser ""
        ┃   │ Var 33 = AddUser ""
        ┃   │ Var 34 = AddUser ""
        ┃   │ Var 37 = AddUser ""
        ┃   │ Var 38 = AddUser ""
        ┃   │ Var 41 = AddUser ""
        ┃   │ Var 45 = AddUser ""
        ┃   │ Var 47 = GetUser 15
    119 ┃   resetWS
    120 ┃   executeSequential initialState actions

    This failure can be reproduced by running:
    > recheck (Size 12) (Seed 2976784816810995551 (-47094630645854485)) sequential

  ✗ 1 failed.

That is, after inserting 16 users, we don't see any user when trying to get that 16th user (User ID 15). That's a proper bug in the server.

As a matter of fact, this is the bug I put into the server and was hoping to find. In particular, I wanted hedgehog to find the minimal sequence leading to this bug.¹ Which it clearly has!

The API is the same as in the post on using QuickCheck, with one little difference, I've been lazy when implementing GET /users/:id and return a list of users (that makes it easy to represent a missing :id).

Just like last time I'm using as simple a model as I think I can get away with, based on the API above:

newtype State (v :: * -> *)= State (M.Map Int Text)
  deriving (Eq, Show)

initialState :: State v
initialState = State M.empty

That extra v is something that hedgehog requires. Why? I don't really know, and luckily I don't have to care to make it all work. One thing though, the language pragma KindSignatures is necessary to use that kind of syntax.

Representing an API call requires three things

1. a type
2. an implementation of HTraversable for the type
3. a function producing a Command for the type

I represent the three API calls with these three types

newtype AddUser (v :: * -> *) = AddUser Text
  deriving (Eq, Show)

newtype DeleteUser (v :: * -> *) = DeleteUser Int
  deriving (Eq, Show)

newtype GetUser (v :: * -> *) = GetUser Int
  deriving (Eq, Show)

Again that v pops up, but as with the model state, there's no need to pay any attention to it.

For the implementation of HTraversable I was greatly helped by the registry example. Their implementations are fairly straight forward, which is a good thing since the need for them is internal to hedgehog.

instance HTraversable AddUser where
  htraverse _ (AddUser n) = AddUser <$> pure n

instance HTraversable DeleteUser where
  htraverse _ (DeleteUser i) = DeleteUser <$> pure i

instance HTraversable GetUser where
  htraverse _ (GetUser i) = GetUser <$> pure i

Once these two things are out of the way we get to the meat of the implementation of the API calls, a function creating a Command instance for each type of API call. The exact type for all three functions will be

(MonadGen n, MonadIO m) => Command n m State

which doesn't say a whole lot, I think. After reading the documentation I found it a little clearer, but the two examples, state machine testing and registry, was what cleared things up for me.¹ In an attempt at being overly explicit I wrote these functions in the same style. This is what it ended up looking like for the AddUser type:

addUser :: (MonadGen n, MonadIO m) => Command n m State
addUser = Command gen exec [ Update u
                           , Ensure e
                           ]
  where
    gen _ = Just $ AddUser <$> Gen.text (Range.linear 0 42) Gen.alpha

    exec (AddUser n) = liftIO $ do
      mgr <- newManager defaultManagerSettings
      addReq <- parseRequest "POST http://localhost:3000/users"
      let addReq' = addReq { requestBody = RequestBodyLBS (encode $ User 0 n)}
      addResp <- httpLbs addReq' mgr
      let user = decode (responseBody addResp) :: Maybe User
      return (responseStatus addResp, user)

    u (State m) (AddUser n) _o = State $ M.insert k n m
      where
        k = succ $ foldl max 0 (M.keys m)

    e _ _ (AddUser n) (r, ui) = do
      r === status201
      assert $ isJust ui
      (userName <$> ui) === Just n

Piece by piece:

1. gen is the generator of data. It takes one argument, the current state, but for AddUser I have no use for it. The user name is generated using a generator for Text, and rather arbitrarily I limit the names to 42 characters.
2. exec is the action that calls the web service. Here I'm using http-client to make the call and aeson to parse the response into a User. It produces output.
3. u is a function for updating the model state. It's given the current state, the command and the output. All I need to to do for AddUser is to pick a userId and associate it with the generated name.
4. e is a function for checking post-conditions, in other words checking properties that must hold after exec has run and the state has been updated. It's given four arguments, the previous state, the updated state, the command and the output. The tests here are on the HTTP response code and the returned user name. I think that will do for the time being.

The function for DeleteUser follows the same pattern

deleteUser :: (MonadGen n, MonadIO m) => Command n m State
deleteUser = Command gen exec [ Update u
                              , Require r
                              , Ensure e
                              ]
  where
    gen (State m) = case M.keys m of
      [] -> Nothing
      ks -> Just $ DeleteUser <$> Gen.element ks

    exec (DeleteUser i) = liftIO $ do
      mgr <- newManager defaultManagerSettings
      delReq <- parseRequest $ "DELETE http://localhost:3000/users/" ++ show i
      delResp <- httpNoBody delReq mgr
      return $ responseStatus delResp

    u (State m) (DeleteUser i) _ = State $ M.delete i m

    r (State m) (DeleteUser i) = i `elem` M.keys m

    e _ _ (DeleteUser _) r = r === status200

I think only two pieces need further explanation:

1. gen only returns a DeleteUser with an index actually present in the model state. If there are no users in the model then Nothing is returned. As far as I understand that means that generated programs will only make calls to delete existing users.²
2. r is a pre-condition that programs only delete users that exist. At first I had skipped this pre-condition, thinking that it'd be enough to have gen only create delete calls for existing users. However, after reading the documentation of Command and Callback a bit more closely I realised that I might need a pre-condition to make sure that this holds true also while shrinking.

The final function, for GetUser requires no further explanation so I only present it here

getUser :: (MonadGen n, MonadIO m) => Command n m State
getUser = Command gen exec [ Require r
                           , Ensure e
                           ]
  where
    gen (State m) = case M.keys m of
      [] -> Nothing
      ks -> Just $ GetUser <$> Gen.element ks

    exec (GetUser i) = liftIO $ do
      mgr <- newManager defaultManagerSettings
      getReq <- parseRequest $ "GET http://localhost:3000/users/" ++ show i
      getResp <- httpLbs getReq mgr
      let us = decode $ responseBody getResp :: Maybe [User]
      return (status200 == responseStatus getResp, us)

    r (State m) (GetUser i) = i `elem` M.keys m

    e _ _ (GetUser _) (r, us) = do
      r === True
      assert $ isJust us
      (length <$> us) === Just 1

It looks like there are two obvious top-level properties

1. the web service works as expected when all calls are made one at a time (sequential), and
2. the web service works as expected when all calls are made in parallel.

Hedgehog provides two pairs of functions for this

1. a sequential generator with executeSequential, and
2. a parallel generator with executeParallel.

I started with the former only

prop_seq :: Property
prop_seq = property $ do
  actions <- forAll $ Gen.sequential (Range.linear 1 10) initialState [addUser, deleteUser, getUser]
  resetWS
  executeSequential initialState actions

This first creates a generator of programs of at most length 10³, then turning that into a Sequential which can be passed to executeSequential to turn into a Property.

The function resetWS clears out the web service to make sure that the tests start with a clean slate each time. Its definition is

resetWS :: MonadIO m => m ()
resetWS = liftIO $ do
  mgr <- newManager defaultManagerSettings
  resetReq <- parseRequest "POST http://localhost:3000/reset"
  void $ httpNoBody resetReq mgr

The final bit is the main function, which I wrote like this

main :: IO ()
main = do
  res <- checkSequential $ Group "Main" [("sequential", prop_seq)]
  unless res exitFailure

That is, first run the property sequentially (checkSequential) and if that fails exit with failure.

When running the test fails and gives me a program that breaks the property, and exactly what fails:

━━━ Main ━━━
  ✗ sequential failed after 13 tests and 1 shrink.

        ┏━━ tst/test-01.hs ━━━
     89 ┃ getUser :: (MonadGen n, MonadIO m) => Command n m State
     90 ┃ getUser = Command gen exec [ Require r
     91 ┃                            , Ensure e
     92 ┃                            ]
     93 ┃   where
     94 ┃     gen (State m) = case M.keys m of
     95 ┃       [] -> Nothing
     96 ┃       ks -> Just $ GetUser <$> Gen.element ks
     97 ┃
     98 ┃     exec (GetUser i) = liftIO $ do
     99 ┃       mgr <- newManager defaultManagerSettings
    100 ┃       getReq <- parseRequest $ "GET http://localhost:3000/users/" ++ show i
    101 ┃       getResp <- httpLbs getReq mgr
    102 ┃       let us = decode $ responseBody getResp :: Maybe [User]
    103 ┃       return (status200 == responseStatus getResp, us)
    104 ┃
    105 ┃     r (State m) (GetUser i) = i `elem` M.keys m
    106 ┃
    107 ┃     e _ _ (GetUser _) (r, us) = do
    108 ┃       r === True
    109 ┃       assert $ isJust us
    110 ┃       (length <$> us) === Just 1
        ┃       ^^^^^^^^^^^^^^^^^^^^^^^^^^
        ┃       │ Failed (- lhs =/= + rhs)
        ┃       │ - Just 0
        ┃       │ + Just 1

        ┏━━ tst/test-01.hs ━━━
    118 ┃ prop_seq :: Property
    119 ┃ prop_seq = property $ do
    120 ┃   actions <- forAll $ Gen.sequential (Range.linear 1 10) initialState [addUser, deleteUser, getUser]
        ┃   │ Var 0 = AddUser ""
        ┃   │ Var 1 = GetUser 1
    121 ┃   resetWS
    122 ┃   executeSequential initialState actions

    This failure can be reproduced by running:
    > recheck (Size 12) (Seed 6041776208714975061 (-2279196309322888437)) sequential

  ✗ 1 failed.

My goodness, that is pretty output!

Anyway, I'd say that the failing program has been shrunk to be minimal so I'd say that all in all this is a big step up from what I had earlier. Sure, using the hedgehog state machine API is slightly involved, but once worked out I find it fairly straight-forward and it most likely is written by people much more knowledgable than me and better than anything I could produce. Having to use generators explicitly (the hedgehog way) is neither easier nor more complicated than defining a few type class instances (the QuickCheck way). Finally, the integrated shrinking is rather brilliant and not having to implement that myself is definitely a big benefit.

Now I only have to fix the errors in the web service that the test reveal. This post is already rather long, so I'll keep that for a future post.

I decided to make a few changes to the example in the article:

• I removed the modify function, instead the code uses the typeclass function modifyBalance directly.
• I separated the instances needed for the tests spatially in the code just to make it easier to see what's "production" code and what's test code.
• I combined the main functions from the various examples to that both an example (main0) and the test (main1) are run.
• I switched from Control.Concurrent.Async.Lifted.Safe (from monad-control) to UnliftIO.Async (from unliftio)

After that the code looks like this

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}

import           Control.Concurrent.STM
import           Control.Monad.Reader
import qualified Control.Monad.State.Strict as State
import           Say
import           Test.Hspec
import           UnliftIO.Async

data Env = Env
  { envLog :: !(String -> IO ())
  , envBalance :: !(TVar Int)
  }

class HasLog a where
  getLog :: a -> (String -> IO ())

instance HasLog Env where
  getLog = envLog

class HasBalance a where
  getBalance :: a -> TVar Int

instance HasBalance Env where
  getBalance = envBalance

class Monad m => MonadBalance m where
  modifyBalance :: (Int -> Int) -> m ()

instance (HasBalance env, MonadIO m) => MonadBalance (ReaderT env m) where
  modifyBalance f = do
    env <- ask
    liftIO $ atomically $ modifyTVar' (getBalance env) f

logSomething :: (MonadReader env m, HasLog env, MonadIO m) => String -> m ()
logSomething msg = do
  env <- ask
  liftIO $ getLog env msg

main0 :: IO ()
main0 = do
  ref <- newTVarIO 4
  let env = Env { envLog = sayString , envBalance = ref }
  runReaderT
    (concurrently_
      (modifyBalance (+ 1))
      (logSomething "Increasing account balance"))
    env
  balance <- readTVarIO ref
  sayString $ "Final balance: " ++ show balance

instance HasLog (String -> IO ()) where
  getLog = id

instance HasBalance (TVar Int) where
  getBalance = id

instance Monad m => MonadBalance (State.StateT Int m) where
  modifyBalance = State.modify

main1 :: IO ()
main1 = hspec $ do
  describe "modify" $ do
    it "works, IO" $ do
      var <- newTVarIO (1 :: Int)
      runReaderT (modifyBalance (+ 2)) var
      res <- readTVarIO var
      res `shouldBe` 3
    it "works, pure" $ do
      let res = State.execState (modifyBalance (+ 2)) (1 :: Int)
      res `shouldBe` 3
  describe "logSomething" $
    it "works" $ do
      var <- newTVarIO ""
      let logFunc msg = atomically $ modifyTVar var (++ msg)
          msg1 = "Hello "
          msg2 = "World\n"
      runReaderT (logSomething msg1 >> logSomething msg2) logFunc
      res <- readTVarIO var
      res `shouldBe` (msg1 ++ msg2)

main :: IO ()
main = main0 >> main1

I think the distinguising features are

• The application environmant, Env will contain configuraiton values (not in this example), state, envBalance, and functions we might want to vary, envLog
• There is no explicit type representing the execution context
• Typeclasses are used to abstract over application environment, HasLog and HasBalance
• Typeclasses are used to abstract over operations, MonadBalance
• Typeclasses are implemented for both the application environment, HasLog and HasBalance, and the execution context, MonadBalance

In the end this makes for code with very loose couplings; there's not really any single concrete type that implements all the constraints to work in the "real" main function (main0). I could of course introduce a type synonym for it

type App = ReaderT Env IO

but it brings no value – it wouldn't be used explicitly anywhere.

In order to compare the ReaderT design pattern to tagless final (as I understand it) I made an attempt to translate the code above. The code below is the result.¹

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

import           Control.Concurrent.STM
import qualified Control.Monad.Identity as Id
import           Control.Monad.Reader
import qualified Control.Monad.State.Strict as State
import           Say
import           Test.Hspec
import           UnliftIO (MonadUnliftIO)
import           UnliftIO.Async

newtype Env = Env {envBalance :: TVar Int}

newtype AppM a = AppM {unAppM :: ReaderT Env IO a}
  deriving (Functor, Applicative, Monad, MonadIO, MonadReader Env, MonadUnliftIO)

runAppM :: Env -> AppM a -> IO a
runAppM env app = runReaderT (unAppM app) env

class Monad m => ModifyM m where
  mModify :: (Int -> Int) -> m ()

class Monad m => LogSomethingM m where
  mLogSomething :: String -> m()

instance ModifyM AppM where
  mModify f = do
    ref <- asks envBalance
    liftIO $ atomically $ modifyTVar' ref f

instance LogSomethingM AppM where
  mLogSomething = liftIO . sayString

main0 :: IO ()
main0 = do
  ref <- newTVarIO 4
  let env = Env ref
  runAppM env
    (concurrently_
      (mModify (+ 1))
      (mLogSomething "Increasing account balance"))
  balance <- readTVarIO ref
  sayString $ "Final balance: " ++ show balance

newtype ModifyAppM a = ModifyAppM {unModifyAppM :: State.StateT Int Id.Identity a}
  deriving (Functor, Applicative, Monad, State.MonadState Int)

runModifyAppM :: Int -> ModifyAppM a -> (a, Int)
runModifyAppM s app = Id.runIdentity $ State.runStateT (unModifyAppM app) s

instance ModifyM ModifyAppM where
  mModify = State.modify'

newtype LogAppM a = LogAppM {unLogAppM :: ReaderT (TVar String) IO a}
  deriving (Functor, Applicative, Monad, MonadIO, MonadReader (TVar String))

runLogAppM :: TVar String -> LogAppM a -> IO a
runLogAppM env app = runReaderT (unLogAppM app) env

instance LogSomethingM LogAppM where
  mLogSomething msg = do
    var <- ask
    liftIO $ atomically $ modifyTVar var (++ msg)

main1 :: IO ()
main1 = hspec $ do
  describe "mModify" $ do
    it "works, IO" $ do
      var <- newTVarIO 1
      runAppM (Env var) (mModify (+ 2))
      res <- readTVarIO var
      res `shouldBe` 3
    it "works, pure" $ do
      let (_, res) = runModifyAppM 1 (mModify (+ 2))
      res `shouldBe` 3
  describe "mLogSomething" $
    it "works" $ do
      var <- newTVarIO ""
      runLogAppM var (mLogSomething "Hello" >> mLogSomething "World!")
      res <- readTVarIO var
      res `shouldBe` "HelloWorld!"

main :: IO ()
main = main0 >> main1

The steps for the "real" part of the program were

1. Introduce an execution type, AppM, with a convenience function for running it, runAppM
2. Remove the log function from the environment type, envLog in Env
3. Remove all the HasX classes
4. Create a new operations typeclass for logging, LogSomethingM
5. Rename the operations typeclass for modifying the balance to match the naming found in the tagless article a bit better, ModifyM
6. Implement instances of both operations typeclasses for AppM

For testing the steps were

1. Define an execution type for each test, ModifyAppM and LogAppM, with some convenience functions for running them, runModifyAppM and runLogAppM
2. Write instances for the operations typeclasses, one for each

So I think the distinguising features are

• There's both an environment type, Env, and an execution type AppM that wraps it
• The environment holds only configuration values (none in this example), and state (envBalance)
• Typeclasses are used to abstract over operations, LogSomethingM and ModifyM
• Typeclasses are only implemented for the execution type

This version has slightly more coupling, the execution type specifies the environment to use, and the operations are tied directly to the execution type. However, this coupling doesn't really make a big difference – looking at the pure modify test the amount of code don't differ by much.

My theoretical knowledge isn't anywhere near good enough to say anything objectively about the difference in expressiveness of the two design patterns. That means that my conclusion comes down to taste, do you like the readerT patter or tagless final better?

I like the slightly looser coupling I get with the ReaderT pattern. Loose coupling is (almost) always a desirable goal. However, I can see that tying the typeclass instances directly to a concrete execution type results in the intent being communicated a little more clearly. Clearly communicating intent in code is also a desirable goal. In particular I suspect it'll result in more actionable error messages when making changes to the code – the error will tell me that my execution type lacks an instance of a specific typeclass, instead of it telling me that a particular transformer stack does. On the other hand, in the ReaderT pattern that stack is very shallow.

One possibility would be that one pattern is better suited for libraries and the other for applications. I don't think that's the case though as in both cases the library code would be written in a style that results in typeclass constraints on the caller and providing instances for those typeclasses is roughly an equal amount of work for both styles.

As a first simple little experiment I wrote a tiny little web server that would print a string to stdout when receiving the request to GET /route0.

The printing to stdout is the operation I want to make abstract.

class Monad m => MonadPrinter m where
  mPutStrLn :: Text -> m ()

I then created an application type that is an instance of that class.

newtype AppM a = AppM { unAppM :: IO a }
  deriving (Functor, Applicative, Monad, MonadIO)

instance MonadPrinter AppM where
  mPutStrLn t = liftIO $ putStrLn (unpack t)

Then I added a bit of Scotty boilerplate. It's not strictly necessary, but does make the code a bit nicer to read.

type FooM = ScottyT Text AppM
type FooActionM = ActionT Text AppM

foo :: MonadIO m => Port -> ScottyT Text AppM () -> m ()
foo port = scottyT port unAppM

With that in place the web server itself is just a matter of tying it all together.

main :: IO ()
main = do
  foo 3000 $ do
    get "/route0" $ do
      lift $ mPutStrLn "getting /route0"
      json $ object ["route0" .= ("ok" :: String)]
    notFound $ json $ object ["error" .= ("not found" :: String)]

That was simple enough.

In order to try out how to deal with configuration I added a class for doing some simple logging

class Monad m => MonadLogger m where
  mLog :: Text -> m ()

The straight forward way to deal with configuration is to create a monad stack with ReaderT and since it's logging I want to do the configuration consists of a single LoggerSet (from fast-logger).

newtype AppM a = AppM { unAppM :: ReaderT LoggerSet IO a }
  deriving (Functor, Applicative, Monad, MonadIO, MonadReader LoggerSet)

That means the class instance can be implemented like this

instance MonadLogger AppM where
  mLog msg = do
    ls <- ask
    liftIO $ pushLogStrLn ls $ toLogStr msg

Of course foo has to be changed too, and it becomes a little easier with a wrapper for runReaderT and unAppM.

foo :: MonadIO m => LoggerSet -> Port -> ScottyT Text AppM () -> m ()
foo ls port = scottyT port (`runAppM` ls)

runAppM :: AppM a -> LoggerSet -> IO a
runAppM app ls = runReaderT (unAppM app) ls

With that in place the printing to stdout can be replaced by a writing to the log.

main :: IO ()
main = do
  ls <- newStdoutLoggerSet defaultBufSize
  foo ls 3000 $ do
    get "/route0" $ do
      lift $ mLog "log: getting /route0"
      json $ object ["route0" .= ("ok" :: String)]
    notFound $ json $ object ["error" .= ("not found" :: String)]

Not really a big change, I'd say. Extending the configuration is clearly straight forward too.

At work we use correlation IDs¹ and I think that the most convenient way to deal with it is to put the correlation ID into the configuration after extracting it. That is, I want to modify the configuration on each request. Luckily it turns out to be possible to do that, despite using ReaderT for holding the configuration.

I can't be bothered with a full implementation of correlation ID for this little experiment, but as long as I can get a new AppM by running a function on the configuration it's just a matter of extracting the correct header from the request. For this experiment it'll do to just modify an integer in the configuration.

I start with defining a type for the configuration and changing AppM.

type Config = (LoggerSet, Int)

newtype AppM a = AppM { unAppM :: ReaderT Config IO a }
  deriving (Functor, Applicative, Monad, MonadIO, MonadReader Config)

The logger instance has to be changed accordingly of course.

instance MonadLogger AppM where
  mLog msg = do
    (ls, i) <- ask
    liftIO $ pushLogStrLn ls $ toLogStr msg <> toLogStr (":" :: String) <> toLogStr (show i)

The get function that comes with scotty isn't going to cut it, since it has no way of modifying the configuration, so I'll need a new one.

mGet :: ScottyError e => RoutePattern -> ActionT e AppM () -> ScottyT e AppM ()
mGet p a = get p $ do
  withCfg (\ (ls, i) -> (ls, succ i)) a

The tricky bit is in the withCfg function. It's indeed not very easy to read, I think

withCfg = mapActionT . withAppM
  where
    mapActionT f (ActionT a) = ActionT $ (mapExceptT . mapReaderT . mapStateT) f a
    withAppM f a = AppM $ withReaderT f (unAppM a)

Basically it reaches into the guts of scotty's ActionT type (the details are exposed in Web.Scotty.Internal.Types, thanks for not hiding it completely), and modifies the ReaderT Config I've supplied.

The new server has two routes, the original one and a new one at GET /route1.

main :: IO ()
main = do
  putStrLn "Starting"
  ls <- newStdoutLoggerSet defaultBufSize
  foo (ls, 0) 3000 $ do
    get "/route0" $ do
      lift $ mLog "log: getting /route0"
      json $ object ["route0" .= ("ok" :: String)]
    mGet "/route1" $ do
      lift $ mLog "log: getting /route1"
      json $ object ["route1" .= ("bar" :: String)]
    notFound $ json $ object ["error" .= ("not found" :: String)]

It's now easy to verify that the original route, GET /route0, logs a string containing the integer '0', while the new route, GET /route1, logs a string containing the integer '1'.

For configuration it decided to use the reader monad inside ActionT from Scotty. Enter Chell:

type ChellM c = ScottyT Text (ReaderT c IO)
type ChellActionM c = ActionT Text (ReaderT c IO)

In order to run it I wrote a function corresponding to scotty:

chell :: c -> Port -> ChellM () -> IO ()
chell cfg port a = scottyOptsT opts (flip runReaderT cfg) a
  where
    opts = def { verbose = 0
               , settings = (settings def) { settingsPort = port }
               }

To deal with the correlation ID each incoming request should be checked for the HTTP header X-Correlation-Id and if present it should be used during logging. If no such header is present then a new correlation ID should be created. Since it's per request it feels natural to create a WAI middleware for this.

The easiest way I could come up with was to push the correlation ID into the request's headers before it's passed on:

requestHeaderCorrelationId :: Request -> Maybe ByteString
requestHeaderCorrelationId = lookup "X-Correlation-Id" . requestHeaders

correlationId ::  Middleware
correlationId app req sendResponse = do
  u <- (randomIO :: IO UUID)
  let corrId = maybe (toASCIIBytes u) id (requestHeaderCorrelationId req)
      newHeaders = ("X-Correlation-Id", corrId) : (requestHeaders req)
  app (req { requestHeaders = newHeaders }) $ \ res -> sendResponse res

It also turns out to be useful to have both a default correlation ID and a function for pulling it out of the headers:

defaultCorrelationString :: ByteString
defaultCorrelationString = "no-correlation-id"

getCorrelationId :: Request -> ByteString
getCorrelationId r = maybe defaultCorrelationString id (requestHeaderCorrelationId r)

Since the correlation ID should be picked out of the request on handling of every request it's useful to have it the configuration when running the ChellActionM actions. However, since the correlation ID isn't available when running the reader (the call to runReaderT in chell) something else is called for. When looking around I found local (and later I was pointed to the more general withReaderT) but it doesn't have a suitable type. After some help on Twitter I arrived at withConfig which allows me to run an action in a modified configuration:

withConfig :: (c -> c') -> ChellActionM c' () -> ChellActionM c ()
withConfig = mapActionT . withReaderT
  where
    mapActionT f (ActionT a) = ActionT $ (mapExceptT . mapReaderT . mapStateT) f a

Armed with this I can put together some functions to replace Scotty's get, post, etc. With a configuration type like this:

data Config = Cfg LoggerSet ByteString

The modified get looks like this (Scotty's original is S.get)

get :: RoutePattern -> ChellActionM Config () -> ChellM Config ()
get p a = S.get p $ do
  r <- request
  let corrId = getCorrelationId r
  withConfig (\ (Cfg l _) -> Cfg l corrId) a

With this in place I can use the simpler ReaderT Config IO for inner functions that need to log.

I want to use QuickCheck to test a REST API, just like in the case of the C API the idea is to

1. generate a sequence of API calls (a program), then
2. run the sequence against a model, as well as
3. run the sequence against the web service, and finally
4. compare the resulting model against reality.

I'll use a small web service I'm working on, and then concentrate on only a small part of the API to begin with.

The parts of the API I'll use for the programs at this stage are

The following API calls will also be used, but not in the programs

Given the information about the API above it seems the following is enough to represent the two calls of interest together with a constructor representing the end of a program

data ApiCall = AddUser Text
             | DeleteUser Int
             | EndProgram
             deriving (Show)

and a program is just a sequence of calls, so list of ApiCall will do. However, since I want to generate sequences of calls, i.e. implement Arbitrary, I'll wrap it in a newtype

newtype Program = Prog [ApiCall]

First of all I need to decide what model to use. Based on the part of the API I'm using I'll use an ordinary dictionary of Int and Text

type Model = M.Map Int Text

Simulating execution of a program is simulating each call against a model that's updated with each step. I expect the final model to correspond to the state of the real service after the program is run for real. The simulation begins with an empty dictionary.

simulateProgram :: Program -> Model
simulateProgram (Prog cs) = foldl simulateCall M.empty cs

The simulation of the API calls must then be a function taking a model and a call, returning an updated model

simulateCall :: Model -> ApiCall -> Model
simulateCall m (AddUser t) = M.insert k t m
  where
    k = succ $ foldl max 0 (M.keys m)
simulateCall m (DeleteUser k) = M.delete k m
simulateCall m EndProgram = m

Here I have to make a few assumptions. First, I assume the indeces for the users start on 1. Second, that the next index used always is the successor of highest currently used index. We'll see how well this holds up to reality later on.

Running the program against the actual web service follows the same pattern, but here I'm dealing with the real world, so it's a little more messy, i.e. IO is involved. First the running of a single call

runCall :: Manager -> ApiCall -> IO ()
runCall mgr (AddUser t) = do
  ireq <- parseRequest "POST http://localhost:3000/users"
  let req = ireq { requestBody = RequestBodyLBS (encode $ User 0 t)}
  resp <- httpLbs req mgr
  guard (status201 == responseStatus resp)

runCall mgr (DeleteUser k) = do
  req <- parseRequest $ "DELETE http://localhost:3000/users/" ++ show k
  resp <- httpNoBody req mgr
  guard (status200 == responseStatus resp)

runCall _ EndProgram = return ()

The running of a program is slightly more involved. Of course I have to set up the Manager needed for the HTTP calls, but I also need to

1. ensure that the web service is in a well-known state before starting, and
2. extract the state of the web service after running the program, so I can compare it to the model

runProgram :: Program -> IO Model
runProgram (Prog cs) = do
  mgr <- newManager defaultManagerSettings
  resetReq <- parseRequest "POST http://localhost:3000/reset"
  httpNoBody resetReq mgr
  mapM_ (runCall mgr) cs
  model <- extractModel mgr
  return model

The call to POST /reset resets the web service. I would have liked to simply restart the service completely, but I failed in automating it. I think I'll have to take a closer look at the implementation of scotty to find a way.

Extracting the web service state and packaging it in a Model is a matter of calling GET /users and then repeatedly calling GET /users/:id with each id gotten from the first call

extractModel :: Manager -> IO Model
extractModel mgr = do
  req <- parseRequest "http://localhost:3000/users"
  resp <- httpLbs req mgr
  let (Just ids) = decode (responseBody resp) :: Maybe [Int]
  users <- forM ids $ \ id -> do
    req <- parseRequest $ "http://localhost:3000/users/" ++ show id
    resp <- httpLbs req mgr
    let (Just (user:_)) = decode (responseBody resp) :: Maybe [User]
    return user
  return $ foldl (\ map (User id name) -> M.insert id name map) M.empty users

My approach to generating a program is based on the idea that given a certain state there is only a limited number of possible calls that make sense. Given a model m it makes sense to make one of the following calls:

• add a new user
• delete an existing user
• end the program

Based on this writing genProgram is rather straight forward

genProgram :: Gen Program
genProgram = Prog <$> go M.empty
  where
    possibleAddUser _ = [AddUser <$> arbitrary]
    possibleDeleteUser m = map (return . DeleteUser) (M.keys m)
    possibleEndProgram _ = [return EndProgram]

    go m = do
      let possibles = possibleDeleteUser m ++ possibleAddUser m ++ possibleEndProgram m
      s <- oneof possibles
      let m' = simulateCall m s
      case s of
        EndProgram -> return []
        _ -> (s:) <$> go m'