Generalize StrictT(M)Var invariant

io-sim-classes/io-sim-classes.cabal

@@ -18,6 +18,11 @@ source-repository head
   location: https://github.com/input-output-hk/ouroboros-network
   subdir:   io-sim-classes
 
+flag checktvarinvariant
+  Description: Enable runtime invariant checks on StrictT(M)Var
+  Manual: True
+  Default: False
+
 library
   hs-source-dirs:      src
 
@@ -53,3 +58,5 @@ library
                        -Wno-unticked-promoted-constructors
                        -fno-ignore-asserts
 
+  if flag(checktvarinvariant)
+    cpp-options: -DCHECK_TVAR_INVARIANT

io-sim-classes/src/Control/Monad/Class/MonadSTM/Strict.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns          #-}
+{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns        #-}
 module Control.Monad.Class.MonadSTM.Strict
@@ -31,7 +32,6 @@ module Control.Monad.Class.MonadSTM.Strict
   , isEmptyTMVar
   ) where
 
-import           Control.Exception (assert)
 import           Control.Monad.Class.MonadSTM as X hiding (LazyTMVar, LazyTVar,
                      isEmptyTMVar, modifyTVar, newEmptyTMVar, newEmptyTMVarM,
                      newTMVar, newTMVarM, newTVar, newTVarM, putTMVar,
@@ -45,9 +45,8 @@ import           GHC.Stack
 -------------------------------------------------------------------------------}
 
 data StrictTVar m a = StrictTVar
-   { invariant :: !(a -> Bool)
-     -- ^ Invariant checked in an 'assert' whenever storing an @a@ in the
-     -- 'StrictTVar'.
+   { invariant :: !(a -> Maybe String)
+     -- ^ Invariant checked whenever updating the 'StrictTVar'.
    , tvar      :: !(Lazy.LazyTVar m a)
    }
 
@@ -56,25 +55,25 @@ toLazyTVar :: StrictTVar m a -> Lazy.LazyTVar m a
 toLazyTVar StrictTVar { tvar } = tvar
 
 newTVar :: MonadSTM m => a -> STM m (StrictTVar m a)
-newTVar !a = StrictTVar (const True) <$> Lazy.newTVar a
+newTVar !a = StrictTVar (const Nothing) <$> Lazy.newTVar a
 
 newTVarM :: MonadSTM m => a -> m (StrictTVar m a)
-newTVarM = newTVarWithInvariantM (const True)
+newTVarM = newTVarWithInvariantM (const Nothing)
 
-newTVarWithInvariantM :: MonadSTM m
-                      => (a -> Bool)  -- ^ Invariant
+newTVarWithInvariantM :: (MonadSTM m, HasCallStack)
+                      => (a -> Maybe String) -- ^ Invariant (expect 'Nothing')
                       -> a
                       -> m (StrictTVar m a)
 newTVarWithInvariantM invariant !a =
-    assert (invariant a) $
+    checkInvariant (invariant a) $
     StrictTVar invariant <$> Lazy.newTVarM a
 
 readTVar :: MonadSTM m => StrictTVar m a -> STM m a
 readTVar StrictTVar { tvar } = Lazy.readTVar tvar
 
-writeTVar :: MonadSTM m => StrictTVar m a -> a -> STM m ()
+writeTVar :: (MonadSTM m, HasCallStack) => StrictTVar m a -> a -> STM m ()
 writeTVar StrictTVar { tvar, invariant } !a =
-    assert (invariant a) $
+    checkInvariant (invariant a) $
     Lazy.writeTVar tvar a
 
 modifyTVar :: MonadSTM m => StrictTVar m a -> (a -> a) -> STM m ()
@@ -92,34 +91,33 @@ updateTVar v f = do
 -------------------------------------------------------------------------------}
 
 data StrictTMVar m a = StrictTMVar
-  { invariant :: !(a -> Bool)
-    -- ^ Used in an 'assert' to check whether the given @a@ is in normal form
-    -- whenever storing an @a@ in the 'StrictTMVar'.
+  { invariant :: !(a -> Maybe String)
+    -- ^ Invariant checked whenever updating the 'StrictTMVar'.
   , tmvar     :: !(Lazy.LazyTMVar m a)
   }
 
 newTMVar :: MonadSTM m => a -> STM m (StrictTMVar m a)
-newTMVar !a = StrictTMVar (const True) <$> Lazy.newTMVar a
+newTMVar !a = StrictTMVar (const Nothing) <$> Lazy.newTMVar a
 
 newTMVarM :: MonadSTM m => a -> m (StrictTMVar m a)
-newTMVarM = newTMVarWithInvariantM (const True)
+newTMVarM = newTMVarWithInvariantM (const Nothing)
 
 newTMVarWithInvariantM :: (MonadSTM m, HasCallStack)
-                       => (a -> Bool)  -- ^ Invariant
+                       => (a -> Maybe String)  -- ^ Invariant (expect 'Nothing')
                        -> a
                        -> m (StrictTMVar m a)
 newTMVarWithInvariantM invariant !a =
-    assert (invariant a) $
+    checkInvariant (invariant a) $
     StrictTMVar invariant <$> Lazy.newTMVarM a
 
 newEmptyTMVar :: MonadSTM m => STM m (StrictTMVar m a)
-newEmptyTMVar = StrictTMVar (const True) <$> Lazy.newEmptyTMVar
+newEmptyTMVar = StrictTMVar (const Nothing) <$> Lazy.newEmptyTMVar
 
 newEmptyTMVarM :: MonadSTM m => m (StrictTMVar m a)
-newEmptyTMVarM = newEmptyTMVarWithInvariantM (const True)
+newEmptyTMVarM = newEmptyTMVarWithInvariantM (const Nothing)
 
 newEmptyTMVarWithInvariantM :: MonadSTM m
-                            => (a -> Bool)  -- ^ Invariant
+                            => (a -> Maybe String)  -- ^ Invariant (expect 'Nothing')
                             -> m (StrictTMVar m a)
 newEmptyTMVarWithInvariantM invariant =
     StrictTMVar invariant <$> Lazy.newEmptyTMVarM
@@ -131,14 +129,14 @@ takeTMVar StrictTMVar { tmvar } = Lazy.takeTMVar tmvar
 tryTakeTMVar :: MonadSTM m => StrictTMVar m a -> STM m (Maybe a)
 tryTakeTMVar StrictTMVar { tmvar } = Lazy.tryTakeTMVar tmvar
 
-putTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m ()
+putTMVar :: (MonadSTM m, HasCallStack) => StrictTMVar m a -> a -> STM m ()
 putTMVar StrictTMVar { tmvar, invariant } !a =
-    assert (invariant a) $
+    checkInvariant (invariant a) $
     Lazy.putTMVar tmvar a
 
-tryPutTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m Bool
+tryPutTMVar :: (MonadSTM m, HasCallStack) => StrictTMVar m a -> a -> STM m Bool
 tryPutTMVar StrictTMVar { tmvar, invariant } !a =
-    assert (invariant a) $
+    checkInvariant (invariant a) $
     Lazy.tryPutTMVar tmvar a
 
 readTMVar :: MonadSTM m => StrictTMVar m a -> STM m a
@@ -147,10 +145,22 @@ readTMVar StrictTMVar { tmvar } = Lazy.readTMVar tmvar
 tryReadTMVar :: MonadSTM m => StrictTMVar m a -> STM m (Maybe a)
 tryReadTMVar StrictTMVar { tmvar } = Lazy.tryReadTMVar tmvar
 
-swapTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m a
+swapTMVar :: (MonadSTM m, HasCallStack) => StrictTMVar m a -> a -> STM m a
 swapTMVar StrictTMVar { tmvar, invariant } !a =
-    assert (invariant a) $
+    checkInvariant (invariant a) $
     Lazy.swapTMVar tmvar a
 
 isEmptyTMVar :: MonadSTM m => StrictTMVar m a -> STM m Bool
 isEmptyTMVar StrictTMVar { tmvar } = Lazy.isEmptyTMVar tmvar
+
+{-------------------------------------------------------------------------------
+  Dealing with invariants
+-------------------------------------------------------------------------------}
+
+checkInvariant :: HasCallStack => Maybe String -> m x -> m x
+#if CHECK_TVAR_INVARIANT
+checkInvariant Nothing    k = k
+checkInvariant (Just err) _ = error $ "Invariant violation: " ++ err
+#else
+checkInvariant _err k       = k
+#endif

ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl.hs

@@ -213,5 +213,5 @@ openDBInternal args launchBgTasks = do
     blockEpoch = epochInfoEpoch (Args.cdbEpochInfo args) . blockSlot
 
     -- TODO (#969): Re-enable this and deal with the fallout.
-    isNF :: forall a. a -> Bool
-    isNF = const True -- unsafePerformIO . isNormalForm
+    isNF :: forall a. a -> Maybe String
+    isNF = const Nothing -- unsafePerformIO . isNormalForm

ouroboros-network/ouroboros-network.cabal

@@ -146,7 +146,6 @@ library
   build-depends:       hashable          >=1.2 && <1.3,
                        text              >=1.2 && <1.3
 
-
 test-suite test-network
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test src