test: Flesh out the NullDbT implementation.

The `NullDbT` type now properly implements the `MonadDb` spec and
behaves as one would expect from a `MonadDb` implementation, save for
the fact that it's not backed by a persistent store. As before, do not
use this type in production!

In this commit, we also test the `NullDbT` implementation fairly
thoroughly. This may seem a bit odd for a database implementation
that's only intended for testing use itself, but we want to be sure
that our core implementation behaves as expected before building more
tests on that foundation.

There are some serious DRY violations in the test code in this commit.
Much of it is copied from our `primer-rel8` tests. We really need to
factor out a lot of reusable testing code into a separate lib. (See
#273.) However, I'll
leave that work for a later PR, as it will require a pretty
substantial amount of refactoring.

primer/primer.cabal

@@ -102,6 +102,7 @@ test-suite primer-test
     Tests.FreeVars
     Tests.Gen.Core.Typed
     Tests.Module
+    Tests.NullDb
     Tests.Primitives
     Tests.Prog
     Tests.Question
@@ -141,6 +142,7 @@ test-suite primer-test
       , base
       , bytestring
       , containers
+      , exceptions
       , extra
       , filepath
       , generic-optics
@@ -161,6 +163,7 @@ test-suite primer-test
       , tasty-hunit       ^>=0.10.0
       , text
       , uniplate
+      , uuid
 
 --TODO This currently breaks with haskell.nix, so we manually add it to `flake.nix` instead.
 -- See: https://github.com/input-output-hk/haskell.nix/issues/839

primer/src/Primer/Database.hs

@@ -19,7 +19,11 @@ module Primer.Database (
   MonadDb (..),
   DbError (..),
   NullDbT (..),
+  runNullDbT,
   NullDb,
+  runNullDb,
+  runNullDb',
+  NullDbException (..),
   Version,
   serve,
 ) where
@@ -32,7 +36,12 @@ import Control.Concurrent.STM (
   putTMVar,
   readTBQueue,
  )
-import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
+import Control.Monad.Catch (
+  MonadCatch,
+  MonadMask,
+  MonadThrow,
+  throwM,
+ )
 import Control.Monad.Cont (MonadCont)
 import Control.Monad.Fix (MonadFix)
 import Control.Monad.STM (atomically)
@@ -247,16 +256,10 @@ data DbError
     SessionIdNotFound SessionId
   deriving (Eq, Show, Generic)
 
--- | A "null" database type that effectively does nothing.
---
--- This type is really only useful for mocking/testing or "toy"
--- environments. It ignores writes, returns an error when you ask it
--- to look up a session ID, and presents the same list of sessions as
--- the in-memory database (i.e., the 'Sessions' type, which is managed
--- in "Primer.API").
+-- | A "null" database type with no persistent backing store.
 --
--- Note that it keeps around a copy of the in-memory database so that
--- it can mock the 'ListSessions' database operation.
+-- This type is only useful for mocking/testing or "toy" environments.
+-- Do not use this type in production!
 newtype NullDbT m a = NullDbT {unNullDbT :: ReaderT Sessions m a}
   deriving
     ( Functor
@@ -282,15 +285,76 @@ newtype NullDbT m a = NullDbT {unNullDbT :: ReaderT Sessions m a}
 -- | The 'NullDbT' monad transformer applied to 'IO'.
 type NullDb a = NullDbT IO a
 
-instance (MonadIO m) => MonadDb (NullDbT m) where
-  insertSession _ _ _ _ = pure ()
-  updateSessionApp _ _ _ = pure ()
-  updateSessionName _ _ _ = pure ()
+-- | A simple 'Exception' type for 'NullDb' computations.
+newtype NullDbException = NullDbException Text
+  deriving (Eq, Show)
+
+instance Exception NullDbException
+
+instance (MonadThrow m, MonadIO m) => MonadDb (NullDbT m) where
+  insertSession _ id_ a n = do
+    ss <- ask
+    result <- liftIO $
+      atomically $ do
+        lookup <- StmMap.lookup id_ ss
+        case lookup of
+          Nothing -> do
+            StmMap.insert (SessionData a n) id_ ss
+            pure $ Right ()
+          Just _ -> pure $ Left $ NullDbException "insertSession failed because session already exists"
+    case result of
+      Left e -> throwM e
+      Right _ -> pure ()
+  updateSessionApp _ id_ a = ask >>= nullDbRmw (SessionData a . sessionName) id_
+  updateSessionName _ id_ n = ask >>= nullDbRmw (\s -> SessionData (sessionApp s) n) id_
   listSessions ol = do
     ss <- ask
     kvs <- liftIO $ atomically $ ListT.toList $ StmMap.listT ss
-    pure $ pageList ol $ uncurry Session . second sessionName <$> kvs
-  querySessionId sid = pure $ Left $ SessionIdNotFound sid
+    -- Sorting these by name isn't required by the `MonadDb`
+    -- specification, but it's useful for the moment for testing. A
+    -- later version of the `MonadDb` interface will support sorting
+    -- by various keys. See:
+    --
+    -- https://github.com/hackworthltd/primer/issues/533
+    pure $ pageList ol $ sortOn name $ uncurry Session . second sessionName <$> kvs
+  querySessionId sid = do
+    ss <- ask
+    lookup <- liftIO $ atomically $ StmMap.lookup sid ss
+    case lookup of
+      Nothing -> pure $ Left $ SessionIdNotFound sid
+      Just s -> pure $ Right s
+
+-- Read-modify-write a 'NullDbT' session via its in-memory 'Sessions' database.
+nullDbRmw :: (MonadThrow m, MonadIO m) => (SessionData -> SessionData) -> SessionId -> Sessions -> m ()
+nullDbRmw f id_ ss = do
+  result <- liftIO $
+    atomically $ do
+      lookup <- StmMap.lookup id_ ss
+      case lookup of
+        Nothing -> pure $ Left $ NullDbException "updateSessionName lookup failed"
+        Just s -> do
+          StmMap.insert (f s) id_ ss
+          pure $ Right ()
+  case result of
+    Left e -> throwM e
+    Right _ -> pure ()
+
+-- | Run an action in the 'NullDbT' monad with the given initial
+-- 'Sessions' database.
+runNullDbT :: Sessions -> NullDbT m a -> m a
+runNullDbT ss m = runReaderT (unNullDbT m) ss
+
+-- | Run an 'IO' action in the 'NullDb' monad with the given
+-- initial 'Sessions' database.
+runNullDb :: Sessions -> NullDb a -> IO a
+runNullDb = runNullDbT
+
+-- | Run an 'IO' action in the 'NullDb' monad with an empty initial
+-- database.
+runNullDb' :: NullDb a -> IO a
+runNullDb' m = do
+  sessions <- StmMap.newIO
+  runNullDb sessions m
 
 -- | The database service computation.
 --

primer/test/TestUtils.hs

@@ -1,5 +1,7 @@
 -- | Utilities useful across several types of tests.
 module TestUtils (
+  (@?=),
+  assertException,
   withPrimDefs,
   constructTCon,
   constructCon,
@@ -13,9 +15,12 @@ module TestUtils (
   clearTypeMeta,
 ) where
 
-import Foreword
+import Foreword hiding (try)
 
+import Control.Monad.Catch (MonadCatch, try)
 import Control.Monad.Fresh (MonadFresh)
+import Data.String (String)
+import Data.Typeable (typeOf)
 import Optics (over, set, view)
 import Primer.Action (Action (ConstructCon, ConstructRefinedCon, ConstructTCon))
 import Primer.Core (
@@ -43,6 +48,11 @@ import Primer.Core (
 import Primer.Core.Utils (exprIDs)
 import Primer.Name (Name (unName))
 import Primer.Primitives (allPrimDefs)
+import Test.Tasty.HUnit (
+  assertBool,
+  assertFailure,
+ )
+import qualified Test.Tasty.HUnit as HUnit
 
 withPrimDefs :: MonadFresh ID m => (Map GVarName PrimDef -> m a) -> m a
 withPrimDefs f = do
@@ -86,3 +96,24 @@ clearMeta = over _exprMeta (view _metadata) . over _exprTypeMeta (view _metadata
 -- | Clear the backend-created metadata (IDs and cached types) in the given expression
 clearTypeMeta :: Type' TypeMeta -> Type' (Maybe Value)
 clearTypeMeta = over _typeMeta (view _metadata)
+
+(@?=) :: (MonadIO m, Eq a, Show a) => a -> a -> m ()
+x @?= y = liftIO $ x HUnit.@?= y
+infix 1 @?=
+
+type ExceptionPredicate e = (e -> Bool)
+
+assertException ::
+  (HasCallStack, Exception e, MonadIO m, MonadCatch m) =>
+  String ->
+  ExceptionPredicate e ->
+  m a ->
+  m ()
+assertException msg p action = do
+  r <- try action
+  case r of
+    Right _ -> liftIO $ assertFailure $ msg <> " should have thrown " <> exceptionType <> ", but it succeeded"
+    Left e -> liftIO $ assertBool (wrongException e) (p e)
+  where
+    wrongException e = msg <> " threw " <> show e <> ", but we expected " <> exceptionType
+    exceptionType = (show . typeOf) p