A Different Point of View: Interpreting our Monads Without Outside Services

Nov 13

Last week we updated our API to use some interesting monadic constructs. These allowed us to narrow down the places where effects could happen in our application. This week we’ll examine another advantage of this system. We’ll examine how we can simplify our tests and remove the dependency on outside services.

You can follow along this code by looking at the effects-2 branches on the Github repository. In effects-2-start, we’ve updated our tests to use the AppMonad instead of normal IO functions. We can still do better though (see the effects-2-end branch for the final product). We can create a second monad that implements our MonadDatabase and MonadCache classes. This creates what we call a different interpretation of our effects. We can do this in such a way that they don’t rely on running instances of Postgres and Redis.

Re-Imagining our Monad

Let’s imagine the simplest possible way to have a “database”. Instead of using a remote service, we could use in-memory maps. So let’s start with a couple type synonyms:

type UserMap = Map.Map Int64 User
type ArticleMap = Map.Map Int64 Article

There are three different maps in our application. The first map will be our normal Users table from the database. The second map will be the database’s Article table. The third map will refer to our Users cache. Now we’ll create a monad that links all these different elements together, and wraps them in StateT. We’ll then be able to update these maps between requests. We still need IO on our monad stack for reasons we’ll see later.

newtype TestMonad a = TestMonad (StateT (UserMap, ArticleMap, UserMap) IO a)
  deriving (Functor, Applicative, Monad)

instance MonadIO TestMonad where
  liftIO action = TestMonad $ liftIO action

Now we want to create instances of our database type classes for this monad. Let’s start an implementation of MonadDatabase by considering how we’ll fetch a user:

instance MonadDatabase TestMonad where
  fetchUserDB uid = ...

All we need to do is grab the first map out of our state tuple, and then use the normal Map lookup function! We can do the same with an article:

fetchUserDB uid = TestMonad $ do
  userDB <- (view _1) <$> get
  return $ Map.lookup uid userDB

fetchArticleDB aid = TestMonad $ do
  articleDB <- (view _2) <$> get
  return $ Map.lookup aid articleDB

Creating elements is a little more complicated, since we have to generate the keys. This isn’t that hard though! We’ll check if the map is empty and use 1 for the key if there are no entries. Otherwise find the max key and add 1 to it (note that the API for Map.findMax has changed since I wrote this) :

createUserDB user = TestMonad $ do
  (userDB, articleDB, userCache) <- get
  let newUid = if Map.null userDB
        then 1
        else 1 + (fst . Map.findMax) userDB
  ...

Now we’ll create a modified map by inserting our new element. Then we’ll put the modified map back in along with the other maps:

createUserDB user = TestMonad $ do
  (userDB, articleDB, userCache) <- get
  let newUid = if Map.null userDB
        then 1
        else 1 + (fst . Map.findMax) userDB
  let userDB' = Map.insert newUid user userDB
  put (userDB', articleDB, userCache)
  return newUid

createArticleDB article = TestMonad $ do
  (userDB, articleDB, userCache) <- get
  let newAid = if Map.null articleDB
        then 1
        else 1 + (fst . Map.findMax) articleDB
  let articleDB' = Map.insert newAid article articleDB
  put (userDB, articleDB', userCache)
  return newAid

Deletion follows the same general pattern. The only difference is we delete from the map instead of inserting!

deleteUserDB uid = TestMonad $ do
  (userDB, articleDB, userCache) <- get
  let userDB' = Map.delete uid userDB
  put (userDB', articleDB, userCache)

deleteArticleDB aid = TestMonad $ do
  (userDB, articleDB, userCache) <- get
  let articleDB' = Map.delete aid articleDB
  put (userDB, articleDB', userCache)

Now our final two functions will involve actually performing some application logic. To fetch articles by author, we get the list of articles in our database and filter it using the author ID:

fetchArticlesByAuthor uid = TestMonad $ do
  articleDB <- (view _2) <$> get
  return $ map KeyVal (filter articleByAuthor (Map.toList articleDB))
  where
    articleByAuthor (_, article) = articleAuthorId article == toSqlKey uid

For fetching the recent articles, we first sort all the articles in our map by timestamp. Then we take the ten most recent:

fetchRecentArticles = TestMonad $ do
  (userDB, articleDB, _) <- get
  let recentArticles = take 10 (sortBy orderByTimestamp (Map.toList articleDB)) 
  ...
  where
    orderByTimestamp (_, article1) (_, article2) =
      articlePublishedTime article2 `compare` articlePublishedTime article1

But now we have to match each of them with right user. This involves performing a lookup based on the user ID. But then we’re done!

fetchRecentArticles = TestMonad $ do
  (userDB, articleDB, _) <- get
  let recentArticles = take 10 (sortBy orderByTimestamp (Map.toList articleDB)) 
  return $ map (matchWithAuthor userDB) recentArticles
  where
    orderByTimestamp (_, article1) (_, article2) =
      articlePublishedTime article2 `compare` articlePublishedTime article1
    matchWithAuthor userDB (aid, article) =
      case Map.lookup (fromSqlKey (articleAuthorId article)) userDB of
        Nothing -> error "Found article with no user" 
        Just u -> (KeyVal (fromSqlKey (articleAuthorId article), u), KeyVal (aid, article))

Our instance for MonadCache is very similar. We'll manipulate the third map instead of the first 2:

instance MonadCache TestMonad where
  cacheUser uid user = TestMonad $ do
    (userDB, articleDB, userCache) <- get
    let userCache' = Map.insert uid user userCache
    put (userDB, articleDB, userCache')
  fetchCachedUser uid = TestMonad $ do
    userCache <- (view _3) <$> get
    return $ Map.lookup uid userCache
  deleteCachedUser uid = TestMonad $ do
    (userDB, articleDB, userCache) <- get
    let userCache' = Map.delete uid userCache
    put (userDB, articleDB, userCache')

Another Natural Transformation

Now we’re not quite done. We need the ability to run a version of our server that uses this interpretation of our effects. To do this, we need a natural transformation like we had before with AppMonad. Unfortunately, the StateT of our maps won’t get threaded through properly unless we use a pointer to it. This is why we need IO on our stack. Here’s a function that will use a pointer (MVar) to our state, run it, and then swap in the new map.

runStateTWithPointer :: (Exception e, MonadIO m) => StateT s m a -> MVar s -> m (Either e a)
runStateTWithPointer action ref = do
  env <- liftIO $ readMVar ref
  (val, newEnv) <- runStateT action env
  void $ liftIO $ swapMVar ref newEnv
  return $ Right val

Now for our transformation, we’ll take this pointer and run the state. Then we need to catch exceptions like we did in our transformation for AppMonad:

transformTestToHandler :: MVar (UserMap, ArticleMap, UserMap) -> TestMonad :~> Handler
transformTestToHandler sharedMap = NT $ \(TestMonad action) -> do
  result <- liftIO $ handleAny handler $
    runStateTWithPointer action sharedMap 
  Handler $ either throwError return result
  where
    handler :: SomeException -> IO (Either ServantErr a)
    handler e = return $ Left $ err500 { errBody = pack (show e) }

Now when we setup our tests, we’ll run our server using this transformation instead. Notice that we don’t have to do anything with Postgres or Redis here!

setupTests :: IO (ClientEnv, MVar (UserMap, ArticleMap, UserMap), ThreadId)
setupTests = do
  mgr <- newManager tlsManagerSettings
  baseUrl <- parseBaseUrl "http://127.0.0.1:8000"
  let clientEnv = ClientEnv mgr baseUrl
  let initialMap = (Map.empty, Map.empty, Map.empty)
  mapRef <- newMVar initialMap
  tid <- forkIO $
    run 8000 (serve usersAPI (testAPIServer (transformTestToHandler mapRef)))
  threadDelay 1000000
  return (clientEnv, mapRef, tid)

Now when our tests run, they’ll hit a server storing the information in memory instead of a Postgres server. This is super cool!

Integrating with our Tests

Unfortunately, it’s still a little awkward to write our tests. A lot of what they’re actually testing is the internal state of the “database” in question. So we need this function that takes the pointer to the map (the same pointer used by the server) and runs actions on it:

runTestMonad :: MVar (UserMap, ArticleMap, UserMap) -> TestMonad a -> IO a
runTestMonad mapVar (TestMonad action) = do
  currentState <- readMVar mapVar
  (result, newMap) <- runStateT action currentState
  swapMVar mapVar newMap
  return result

Now in our tests, we’ll wrap any calls to the database with this action. Here’s an example of our first before hook:

beforeHook1 :: ClientEnv -> MVar (UserMap, ArticleMap, UserMap) -> IO (Bool, Bool, Bool)
beforeHook1 clientEnv mapVar = do
  callResult <- runClientM (fetchUserClient 1) clientEnv
  let throwsError = isLeft callResult
  (inPG, inRedis) <- runTestMonad mapVar $ do
    inPG <- isJust <$> fetchUserDB 1
    inRedis <- isJust <$> fetchCachedUser 1
    return (inPG, inRedis)
  return (throwsError, inPG, inRedis)

One excellent consequence of using an in-memory map is that we don’t care if there’s data in our “database” at the end. Thus we can completely get rid of our after hooks, which were a bit of a pain!

main :: IO ()
main = do
  (clientEnv, dbMap, tid) <- setupTests
  hspec $ before (beforeHook1 clientEnv dbMap) spec1
  hspec $ before (beforeHook2 clientEnv dbMap) spec2
  hspec $ before (beforeHook3 clientEnv dbMap) spec3
  hspec $ before (beforeHook4 clientEnv dbMap) spec4
  hspec $ before (beforeHook5 clientEnv dbMap) spec5
  hspec $ before (beforeHook6 clientEnv dbMap) spec6
  killThread tid 
  return ()

And now our tests also run perfectly well without needing the docker container to be active! Hooray!

Conclusion

There’s a certain argument that we haven’t really accomplished much. Our app is very shallow, and most of the logic happens within the database calls themselves. Recall that many of our handler functions reduced to the database calls. Hence, the only thing we’re testing right now is our test interpretation!

But it’s easy to imagine that if our application were more complicated, this logic wouldn’t be at the core of our code. In most cases, database queries are the prelude to manipulating the data. And this TestMonad would remove the inconvenience of sourcing that data from outside.

Stay tuned for next week, where we’ll wrap up this consideration of effects by looking at free monads! We’ll consider the “freer-effects” library. It will let us cut down a bit on some of the boilerplate we get with this MTL style approach.

Never tried Haskell before? Do you have visions of conquering all foes with these sorts of abstractions? Check out our Getting Started Checklist and start your journey!

Have you dabbled a little but want to test your skills some more? Take a look at our Recursion Workbook!

Monads

James Bowen

A Different Point of View: Interpreting our Monads Without Outside Services

Re-Imagining our Monad

Another Natural Transformation

Integrating with our Tests

Conclusion

Eff to the Rescue!

Organizing our Effects Effectively