add store for delegations-history

lib/wallet/cardano-wallet.cabal

@@ -188,6 +188,7 @@ library
     , string-interpolate
     , template-haskell
     , temporary
+    , these
     , text
     , text-class
     , these
@@ -241,6 +242,8 @@ library
     Cardano.Wallet.DB.Sqlite.Stores
     Cardano.Wallet.DB.Sqlite.Types
     Cardano.Wallet.DB.Store.Checkpoints
+    Cardano.Wallet.DB.Store.Delegations
+    Cardano.Wallet.DB.Store.QueryStore
     Cardano.Wallet.DB.Store.Meta.Model
     Cardano.Wallet.DB.Store.Meta.Store
     Cardano.Wallet.DB.Store.QueryStore

lib/wallet/src/Cardano/Wallet/DB/Store/Delegations.hs

@@ -0,0 +1,167 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- |
+-- Copyright: © 2022 IOHK
+-- License: Apache-2.0
+--
+-- Delegations-history store and migration from old db tables
+
+module Cardano.Wallet.DB.Store.Delegations
+    ( mkStoreDelegations
+    , migration
+    )
+    where
+
+import Prelude
+
+import Cardano.Pool.Types
+    ( PoolId )
+import Cardano.Slotting.Slot
+    ( SlotNo )
+import Cardano.Wallet.DB.Sqlite.Schema
+    ( DelegationCertificate (DelegationCertificate)
+    , Delegations (..)
+    , EntityField (..)
+    , Key (DelegationsKey)
+    , StakeKeyCertificate (StakeKeyCertificate)
+    )
+import Cardano.Wallet.Delegation.Model
+    ( History, Operation (..), Status (..), slotOf )
+import Cardano.Wallet.Primitive.Types
+    ( WalletId )
+import Control.Exception
+    ( Exception, SomeException (SomeException) )
+import Control.Monad
+    ( when )
+import Data.DBVar
+    ( Store (..) )
+import Data.Delta
+    ( Delta (Base, apply) )
+import Data.Map.Strict
+    ( Map )
+import Data.These
+    ( These (..) )
+import Database.Persist
+    ( Entity (..)
+    , PersistQueryWrite (deleteWhere)
+    , repsert
+    , selectList
+    , (==.)
+    , (>.)
+    )
+import Database.Persist.Sql
+    ( SqlPersistT, insertMany_ )
+
+import qualified Cardano.Wallet.Primitive.Types as W
+import qualified Data.Map.Merge.Strict as Map
+import qualified Data.Map.Strict as Map
+
+mkStoreDelegations :: WalletId -> Store (SqlPersistT IO)
+    (Operation SlotNo PoolId)
+mkStoreDelegations wid =
+    Store
+    { loadS  = loadS' wid
+    , writeS = writeS' wid
+    , updateS = updateS' wid
+    }
+
+loadS'
+    :: WalletId
+    -> SqlPersistT IO (Either SomeException (History SlotNo PoolId))
+loadS' wid = do
+    xs <- selectList  [DelegationWallet ==. wid] []
+    pure $ Map.fromList <$> sequence [decodeStatus x | Entity _ x <- xs ]
+
+data DecodeDelegationError
+    = ActiveDelegationWithoutAPool
+    | UnknownDelegationStatus Int
+    deriving (Show, Eq, Exception)
+
+decodeStatus :: Delegations -> (Either SomeException (SlotNo, Status PoolId))
+decodeStatus (Delegations _wi sn n m_pi) = case n of
+    0 -> Right (sn, Inactive)
+    1 -> Right (sn, Registered)
+    2 -> case m_pi of
+            Nothing -> Left $ SomeException ActiveDelegationWithoutAPool
+            Just pi' -> Right (sn, Active pi')
+    x -> Left $ SomeException $ UnknownDelegationStatus x
+
+updateS'
+    :: WalletId
+    -> History SlotNo PoolId
+    -> Operation SlotNo PoolId
+    -> SqlPersistT IO ()
+updateS' wid h op = do
+    let slot = slotOf op
+        h' = apply op h
+        v' = Map.lookup slot h'
+        v = Map.lookup slot h
+    deleteWhere [DelegationWallet ==. wid , DelegationSlot >. slotOf op ]
+    when (v /= v') $
+        case v' of
+            Nothing -> deleteWhere
+                [DelegationWallet ==. wid , DelegationSlot ==. slotOf op ]
+            Just w -> repsert (DelegationsKey wid slot)
+                $ encodeStatus wid slot w
+
+encodeStatus :: WalletId -> SlotNo -> Status PoolId -> Delegations
+encodeStatus wid slot = \case
+  Inactive -> Delegations wid slot 0 Nothing
+  Registered -> Delegations wid slot 1 Nothing
+  Active pi' -> Delegations wid slot 2 (Just pi')
+
+writeS' :: WalletId -> History SlotNo PoolId -> SqlPersistT IO ()
+writeS' wid h = do
+    deleteWhere [DelegationWallet ==. wid]
+    insertMany_ [encodeStatus wid slot x | (slot, x) <- Map.assocs h]
+
+readOldEncoding
+    :: WalletId
+    -> SqlPersistT IO (Base (Operation SlotNo PoolId))
+readOldEncoding wid = do
+    skcs <- selectList [StakeKeyCertWalletId ==. wid] []
+    dcs <- selectList [CertWalletId ==. wid] []
+    pure $ Map.foldlWithKey' applyChange mempty (slotMap skcs dcs)
+  where
+    applyChange
+        ::  History SlotNo PoolId
+        -> SlotNo
+        -> These W.StakeKeyCertificate (Maybe PoolId)
+        -> History SlotNo PoolId
+    applyChange h s = \case
+        This W.StakeKeyDeregistration -> apply (Deregister s) h
+        This W.StakeKeyRegistration -> apply (Register s) h
+        That Nothing -> h
+        That (Just p) -> apply (Delegate p s) h
+        These W.StakeKeyDeregistration _ -> apply (Deregister s) h
+        These W.StakeKeyRegistration (Just p)
+            -> apply (Delegate p s) $ apply (Register s) h
+        These W.StakeKeyRegistration Nothing
+            ->  apply (Register s) h
+
+    slotMap
+        :: [Entity StakeKeyCertificate]
+        -> [Entity DelegationCertificate]
+        -> Map SlotNo (These W.StakeKeyCertificate (Maybe PoolId))
+    slotMap skcs dcs = mapMergeThese
+        (Map.fromList [(slot, type')
+            | Entity _ (StakeKeyCertificate _ slot type') <- skcs])
+        (Map.fromList [(slot, type')
+            | Entity _ (DelegationCertificate _ slot type') <- dcs])
+
+    mapMergeThese :: Ord k => Map k a -> Map k b -> Map k (These a b)
+    mapMergeThese = Map.merge
+        (Map.mapMaybeMissing $ \_ -> Just . This)
+        (Map.mapMaybeMissing $ \_ -> Just . That)
+        (Map.zipWithMaybeMatched $ \_ x y -> Just $ These x y)
+
+migration :: WalletId -> SqlPersistT IO ()
+migration wid = do
+    old <- readOldEncoding wid
+    writeS' wid old
+    deleteWhere [StakeKeyCertWalletId ==. wid]
+    deleteWhere [CertWalletId ==. wid]