Merge pull request #3701 from input-output-hk/adinapoli/cbr-444

[CBR-444] Use strict MVar in the Kernel

pkgs/default.nix

@@ -18118,6 +18118,7 @@ license = stdenv.lib.licenses.mit;
 , stdenv
 , stm
 , strict
+, strict-concurrency
 , string-conv
 , swagger2
 , tabl
@@ -18227,6 +18228,7 @@ sqlite-simple
 sqlite-simple-errors
 stm
 strict
+strict-concurrency
 swagger2
 tar
 text

wallet-new/cardano-sl-wallet-new.cabal

@@ -241,6 +241,7 @@ library
                      , sqlite-simple-errors
                      , stm
                      , strict
+                     , strict-concurrency
                      , swagger2
                      , tar
                      , text

wallet-new/src/Cardano/Wallet/Kernel.hs

@@ -27,7 +27,6 @@ module Cardano.Wallet.Kernel (
 import           Universum hiding (State)
 
 import           Control.Concurrent.Async (async, cancel)
-import           Control.Concurrent.MVar (modifyMVar, modifyMVar_)
 import           Data.Acid (AcidState, createArchive, createCheckpoint,
                      openLocalStateFrom)
 import           Data.Acid.Memory (openMemoryState)
@@ -50,6 +49,7 @@ import           Cardano.Wallet.Kernel.Read (getWalletSnapshot)
 import           Cardano.Wallet.Kernel.Submission (WalletSubmission,
                      addPendings, emptyWalletSubmission, tick)
 import           Cardano.Wallet.Kernel.Submission.Worker (tickSubmissionLayer)
+import qualified Cardano.Wallet.Kernel.Util.Strict as Strict
 
 {-------------------------------------------------------------------------------
   Passive Wallet Resource Management
@@ -181,7 +181,7 @@ initPassiveWallet logMessage keystore handles node = do
         initSubmission :: PassiveWallet -> IO ()
         initSubmission pw_  = do
             pendings <- pendingByAccount <$> getWalletSnapshot pw_
-            modifyMVar_ (_walletSubmission pw_) $
+            Strict.modifyMVar_ (_walletSubmission pw_) $
                 return . addPendings pendings
 
 {-------------------------------------------------------------------------------
@@ -224,7 +224,7 @@ bracketActiveWallet walletProtocolMagic
         tickFunction :: MVar WalletSubmission -> IO ()
         tickFunction submissionLayer = do
             toSend <-
-                modifyMVar submissionLayer $ \layer -> do
+                Strict.modifyMVar submissionLayer $ \layer -> do
                     let (e, s, state') = tick layer
                     -- cancelPending is called in the MVar IO action so that we can reset the
                     -- state of the wallet using the MVar to block this thread.

wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE RankNTypes                 #-}
@@ -136,7 +137,9 @@ newtype AccountName = AccountName { getAccountName :: Text }
 
 -- | Account index
 newtype HdAccountIx = HdAccountIx { getHdAccountIx :: Word32 }
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Generic)
+
+instance NFData HdAccountIx
 
 -- NOTE(adn) if we need to generate only @hardened@ account indexes, we
 -- need to extend this arbitrary instance accordingly.
@@ -228,7 +231,9 @@ eskToHdRootId = HdRootId . InDb . Core.makePubKeyAddressBoot . Core.encToPublic
 -- as a primary key. This however is a slightly larger refactoring we don't
 -- currently have time for.
 newtype HdRootId = HdRootId { getHdRootId :: InDb Core.Address }
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show, Generic)
+
+instance NFData HdRootId
 
 
 instance Arbitrary HdRootId where
@@ -242,7 +247,9 @@ data HdAccountId = HdAccountId {
       _hdAccountIdParent :: !HdRootId
     , _hdAccountIdIx     :: !HdAccountIx
     }
-  deriving (Eq)
+  deriving (Eq, Generic)
+
+instance NFData HdAccountId
 
 -- | We make sure to compare the account index first to avoid doing an
 -- unnecessary comparison of the root ID

wallet-new/src/Cardano/Wallet/Kernel/DB/InDb.hs

@@ -69,6 +69,9 @@ import           UTxO.Util
 newtype InDb a = InDb { _fromDb :: a }
     deriving (Eq, Show, Ord, Buildable)
 
+instance NFData a => NFData (InDb a) where
+    rnf (InDb a) = rnf a
+
 instance Functor InDb where
     fmap f = InDb . f . _fromDb
 

wallet-new/src/Cardano/Wallet/Kernel/DB/Spec/Pending.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ViewPatterns  #-}
 
 -- | Pending transactions
 --
@@ -61,7 +62,9 @@ import qualified UTxO.Util as Util
 type UnderlyingMap = Map Core.TxId Core.TxAux
 
 -- | Pending transactions
-newtype Pending = Pending (InDb UnderlyingMap) deriving Eq
+newtype Pending = Pending (InDb UnderlyingMap) deriving (Eq, Generic)
+
+instance NFData Pending
 
 deriveSafeCopy 1 'base ''Pending
 

wallet-new/src/Cardano/Wallet/Kernel/Internal.hs

@@ -43,7 +43,7 @@ module Cardano.Wallet.Kernel.Internal (
 
 import           Universum hiding (State)
 
-import           Control.Concurrent.MVar (modifyMVar_)
+import qualified Control.Concurrent.MVar.Strict as Strict
 import           Control.Lens (to)
 import           Control.Lens.TH
 import           Data.Acid (AcidState)
@@ -111,7 +111,7 @@ data PassiveWallet = PassiveWallet {
       -- the active part actually sends stuff across the network. Fortunately,
       -- we already have this split: the submission layer itself is just a
       -- pure data structure, and the sending happens in a separate thread.
-    , _walletSubmission      :: MVar WalletSubmission
+    , _walletSubmission      :: Strict.MVar WalletSubmission
 
       -- | Wallet restoration tasks. Wallets that are in the midst of a restoration
       -- will be doing background work to restore the history. This map holds a
@@ -128,7 +128,7 @@ data PassiveWallet = PassiveWallet {
 -------------------------------------------------------------------------------}
 
 newtype WalletRestorationTask =
-    WalletRestorationTask { _wrt :: MVar (Map WalletId WalletRestorationInfo) }
+    WalletRestorationTask { _wrt :: Strict.MVar (Map WalletId WalletRestorationInfo) }
 
 newRestorationTasks :: IO WalletRestorationTask
 newRestorationTasks = WalletRestorationTask <$> newMVar Map.empty
@@ -148,6 +148,10 @@ data WalletRestorationInfo = WalletRestorationInfo
     -- ^ Restart the restoration task from scratch, using the current tip.
   }
 
+-- Where is really nothing to force here.
+instance NFData WalletRestorationInfo where
+    rnf _ = ()
+
 -- | Data needed to assess the progress of a wallet restoration.
 data WalletRestorationProgress = WalletRestorationProgress
     { _wrpCurrentSlot :: FlatSlotId
@@ -168,7 +172,7 @@ lookupRestorationInfo pw wid = Map.lookup wid <$> currentRestorations pw
 
 addOrReplaceRestoration :: PassiveWallet -> WalletId -> WalletRestorationInfo -> IO ()
 addOrReplaceRestoration pw wId restoreInfo =
-    modifyMVar_ (pw ^. walletRestorationTask . to _wrt) $ \wrt -> do
+    Strict.modifyMVar_ (pw ^. walletRestorationTask . to _wrt) $ \wrt -> do
         -- Cancel any other restorations currently running for this wallet.
        whenJust (Map.lookup wId wrt) cancelRestoration
        -- Register this restoration task with the wallet.
@@ -177,7 +181,7 @@ addOrReplaceRestoration pw wId restoreInfo =
 removeRestoration :: PassiveWallet -> WalletId -> IO ()
 removeRestoration pw wId = do
     wri <- lookupRestorationInfo pw wId
-    modifyMVar_ (pw ^. walletRestorationTask . to _wrt) (pure . Map.delete wId)
+    Strict.modifyMVar_ (pw ^. walletRestorationTask . to _wrt) (pure . Map.delete wId)
     whenJust wri cancelRestoration
 
 currentRestorations :: PassiveWallet -> IO (Map WalletId WalletRestorationInfo)
@@ -191,7 +195,7 @@ restartRestoration = _wriRestart
 
 stopAllRestorations :: PassiveWallet -> IO ()
 stopAllRestorations pw = do
-    modifyMVar_ (pw ^. walletRestorationTask . to _wrt) $ \mp -> do
+    Strict.modifyMVar_ (pw ^. walletRestorationTask . to _wrt) $ \mp -> do
         for_ mp cancelRestoration
         return Map.empty
 

wallet-new/src/Cardano/Wallet/Kernel/Keystore.hs

@@ -32,7 +32,6 @@ module Cardano.Wallet.Kernel.Keystore (
 
 import           Universum
 
-import           Control.Concurrent (modifyMVar, withMVar)
 import qualified Data.List
 import           System.Directory (getTemporaryDirectory, removeFile)
 import           System.IO (hClose, openTempFile)
@@ -45,12 +44,18 @@ import           Pos.Util.Wlog (CanLog (..), HasLoggerName (..), logMessage)
 
 import           Cardano.Wallet.Kernel.DB.HdWallet (eskToHdRootId)
 import           Cardano.Wallet.Kernel.Types (WalletId (..))
+import qualified Cardano.Wallet.Kernel.Util.Strict as Strict
 
 -- Internal storage necessary to smooth out the legacy 'UserSecret' API.
 data InternalStorage = InternalStorage !UserSecret
 
+-- | We are not really interested in fully-forcing the 'UserSecret'. We are
+-- happy here with the operations on the keystore being applied not lazily.
+instance NFData InternalStorage where
+    rnf x = x `seq` ()
+
 -- A 'Keystore'.
-data Keystore = Keystore (MVar InternalStorage)
+data Keystore = Keystore (Strict.MVar InternalStorage)
 
 -- | Internal monad used to smooth out the 'WithLogger' dependency imposed
 -- by 'Pos.Util.UserSecret', to not commit to any way of logging things just yet.
@@ -100,7 +105,7 @@ bracketKeystore deletePolicy fp withKeystore =
 newKeystore :: FilePath -> IO Keystore
 newKeystore fp = fromKeystore $ do
     us <- takeUserSecret fp
-    Keystore <$> newMVar (InternalStorage us)
+    liftIO (Keystore <$> Strict.newMVar (InternalStorage us))
 
 -- | Reads the legacy root key stored in the specified keystore. This is
 -- useful only for importing a wallet using the legacy '.key' format.
@@ -111,22 +116,22 @@ readWalletSecret fp = importKeystore >>= lookupLegacyRootKey
   where
     lookupLegacyRootKey :: Keystore -> IO (Maybe EncryptedSecretKey)
     lookupLegacyRootKey (Keystore ks) =
-        withMVar ks $ \(InternalStorage us) ->
+        Strict.withMVar ks $ \(InternalStorage us) ->
             case us ^. usWallet of
                  Nothing -> return Nothing
                  Just w  -> return (Just $ _wusRootKey w)
 
     importKeystore :: IO Keystore
     importKeystore = fromKeystore $ do
         us <- readUserSecret fp
-        Keystore <$> newMVar (InternalStorage us)
+        liftIO (Keystore <$> Strict.newMVar (InternalStorage us))
 
 
 
 -- | Creates a legacy 'Keystore' by reading the 'UserSecret' from a 'NodeContext'.
 -- Hopefully this function will go in the near future.
 newLegacyKeystore :: UserSecret -> IO Keystore
-newLegacyKeystore us = Keystore <$> newMVar (InternalStorage us)
+newLegacyKeystore us = Keystore <$> Strict.newMVar (InternalStorage us)
 
 -- | Creates a legacy 'Keystore' using a 'bracket' pattern, where the
 -- initalisation and teardown of the resource are wrapped in 'bracket'.
@@ -160,14 +165,14 @@ newTestKeystore = liftIO $ fromKeystore $ do
     (tempFile, hdl) <- liftIO $ openTempFile tempDir "keystore.key"
     liftIO $ hClose hdl
     us <- takeUserSecret tempFile
-    Keystore <$> newMVar (InternalStorage us)
+    liftIO (Keystore <$> Strict.newMVar (InternalStorage us))
 
 -- | Release the resources associated with this 'Keystore'.
 releaseKeystore :: DeletePolicy -> Keystore -> IO ()
 releaseKeystore dp (Keystore ks) =
     -- We are not modifying the 'MVar' content, because this function is
     -- not exported and called exactly once from the bracket de-allocation.
-    withMVar ks $ \internalStorage@(InternalStorage us) -> do
+    Strict.withMVar ks $ \internalStorage@(InternalStorage us) -> do
         fp <- release internalStorage
         case dp of
              KeepKeystoreIfEmpty   -> return ()
@@ -199,7 +204,7 @@ modifyKeystore_ ks f =
 -- | Like 'modifyKeystore_', but it returns a result at the end.
 modifyKeystore :: Keystore -> (UserSecret -> (UserSecret, a)) -> IO a
 modifyKeystore (Keystore ks) f =
-    modifyMVar ks $ \(InternalStorage us) -> do
+    Strict.modifyMVar ks $ \(InternalStorage us) -> do
         let (us', a) = f us
         -- This is a safe operation to be because we acquired the exclusive
         -- lock on this file when we initialised the keystore, and as we are
@@ -263,7 +268,7 @@ lookup :: WalletId
        -> Keystore
        -> IO (Maybe EncryptedSecretKey)
 lookup wId (Keystore ks) =
-    withMVar ks $ \(InternalStorage us) -> return $ lookupKey us wId
+    Strict.withMVar ks $ \(InternalStorage us) -> return $ lookupKey us wId
 
 -- | Lookup a key directly inside the 'UserSecret'.
 lookupKey :: UserSecret -> WalletId -> Maybe EncryptedSecretKey

wallet-new/src/Cardano/Wallet/Kernel/Submission.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE RankNTypes   #-}
+{-# LANGUAGE BangPatterns  #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RankNTypes    #-}
 -- We are exporting Lens' 'Getters', which has a redundant constraint on
 -- \"contravariant\".
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
@@ -89,7 +90,9 @@ data WalletSubmission = WalletSubmission {
     -- to modify it, as that should be done only via this layer's public API.
     -- What we export are some 'Getter's to some interesting bits of the state,
     -- like the local 'Pending' set or the current slot.
-    }
+    } deriving Generic
+
+instance NFData WalletSubmission
 
 instance Buildable WalletSubmission where
     build ws = bprint ("WalletSubmission { rho = <function> , state = " % F.build % " }") (_wsState ws)
@@ -106,7 +109,9 @@ data WalletSubmissionState = WalletSubmissionState {
       _wssPendingMap  ::  M.Map HdAccountId Pending
     , _wssSchedule    ::  Schedule
     , _wssCurrentSlot :: !Slot
-    }
+    } deriving Generic
+
+instance NFData WalletSubmissionState
 
 instance Buildable WalletSubmissionState where
     build wss = bprint ("{ pendingMap = " % (F.later mapBuilder) %
@@ -136,17 +141,25 @@ data Schedule = Schedule {
     -- @N.B@ It should be the wallet's responsibility (not the submission layer's)
     -- to make sure that when it gives up on a transaction @A@, it also gives
     -- up on all transactions @Bs@ that depend on @A@.
-    }
+    } deriving Generic
+
+instance NFData Schedule
 
 -- | A type representing an item (in this context, a transaction) scheduled
 -- to be regularly sent in a given slot (computed by a given 'RetryPolicy').
-data ScheduleSend = ScheduleSend HdAccountId Txp.TxId Txp.TxAux SubmissionCount deriving Eq
+data ScheduleSend = ScheduleSend HdAccountId Txp.TxId Txp.TxAux SubmissionCount
+                  deriving (Eq, Generic)
+
+instance NFData ScheduleSend
 
 -- | A type representing an item (in this context, a transaction @ID@) which
 -- needs to be checked against the blockchain for inclusion. In other terms,
 -- we need to confirm that indeed the transaction identified by the given 'TxId' has
 -- been adopted, i.e. it's not in the local pending set anymore.
-data ScheduleEvictIfNotConfirmed = ScheduleEvictIfNotConfirmed HdAccountId Txp.TxId deriving Eq
+data ScheduleEvictIfNotConfirmed = ScheduleEvictIfNotConfirmed HdAccountId Txp.TxId
+                                 deriving (Eq, Generic)
+
+instance NFData ScheduleEvictIfNotConfirmed
 
 -- | All the events we can schedule for a given 'Slot', partitioned into
 -- 'ScheduleSend' and 'ScheduleEvictIfNotConfirmed'.
@@ -156,7 +169,9 @@ data ScheduleEvents = ScheduleEvents {
     , _seToConfirm :: [ScheduleEvictIfNotConfirmed]
     -- ^ A list of transactions which we need to check if they have been
     -- confirmed (i.e. adopted) by the blockchain.
-    }
+    } deriving Generic
+
+instance NFData ScheduleEvents
 
 instance Semigroup ScheduleEvents where
     (ScheduleEvents s1 c1) <> (ScheduleEvents s2 c2) =
@@ -193,7 +208,9 @@ instance Buildable ScheduleEvents where
 -- implication of a possible overflow: in practice, none, as in case we overflow
 -- the 'Int' positive capacity we will effectively treat this as a \"circular buffer\",
 -- storing the elements for slots @(maxBound :: Int) + 1@ in negative positions.
-newtype Slot = Slot { getSlot :: Word } deriving (Eq, Ord, Show)
+newtype Slot = Slot { getSlot :: Word } deriving (Eq, Ord, Show, Generic)
+
+instance NFData Slot
 
 instance Buildable Slot where
     build (Slot s) = bprint ("Slot " % F.build) s
@@ -216,7 +233,10 @@ mapSlot f (Slot w) = Slot (f w)
 -- Note that when the @Core@ layer will introduce the concept of \"Time to
 -- Live\" for transactions, we will be able to remove the 'maxRetries' value
 -- and simply use the @TTL@ to judge whether or not we should retry.
-newtype SubmissionCount = SubmissionCount { getSubmissionCount :: Int } deriving Eq
+newtype SubmissionCount = SubmissionCount { getSubmissionCount :: Int }
+    deriving (Eq, Generic)
+
+instance NFData SubmissionCount
 
 instance Buildable SubmissionCount where
     build (SubmissionCount s) = bprint F.build s

wallet-new/src/Cardano/Wallet/Kernel/Types.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 module Cardano.Wallet.Kernel.Types (
     -- * Input resolution
     -- ** Raw types
@@ -56,7 +57,9 @@ data WalletId =
     | WalletIdExt ...
     -}
 
-    deriving (Eq, Ord)
+    deriving (Eq, Ord, Generic)
+
+instance NFData WalletId
 
 instance Buildable WalletId where
     build (WalletIdHdRnd rootId) =