{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Cardano.Wallet.DB.WalletState
(
WalletState (..)
, fromGenesis
, getLatest
, findNearestPoint
, WalletCheckpoint (..)
, toWallet
, fromWallet
, getBlockHeight
, getSlot
, DeltaWalletState1 (..)
, DeltaWalletState
, DeltaMap (..)
, ErrNoSuchWallet (..)
, adjustNoSuchWallet
) where
import Prelude
import Cardano.Wallet.Address.Book
( AddressBookIso (..), Discoveries, Prologue )
import Cardano.Wallet.Checkpoints
( Checkpoints )
import Cardano.Wallet.Primitive.Types
( BlockHeader, WalletId )
import Cardano.Wallet.Primitive.Types.UTxO
( UTxO )
import Data.Delta
( Delta (..) )
import Data.DeltaMap
( DeltaMap (..) )
import Data.Generics.Internal.VL
( withIso )
import Data.Generics.Internal.VL.Lens
( over, view, (^.) )
import Data.Map.Strict
( Map )
import Data.Word
( Word32 )
import Fmt
( Buildable (..), pretty )
import GHC.Generics
( Generic )
import qualified Cardano.Wallet.Checkpoints as CPS
import qualified Cardano.Wallet.Primitive.Model as W
import qualified Cardano.Wallet.Primitive.Types as W
import qualified Data.Map.Strict as Map
data WalletCheckpoint s = WalletCheckpoint
{ WalletCheckpoint s -> BlockHeader
currentTip :: !BlockHeader
, WalletCheckpoint s -> UTxO
utxo :: !UTxO
, WalletCheckpoint s -> Discoveries s
discoveries :: !(Discoveries s)
} deriving ((forall x. WalletCheckpoint s -> Rep (WalletCheckpoint s) x)
-> (forall x. Rep (WalletCheckpoint s) x -> WalletCheckpoint s)
-> Generic (WalletCheckpoint s)
forall x. Rep (WalletCheckpoint s) x -> WalletCheckpoint s
forall x. WalletCheckpoint s -> Rep (WalletCheckpoint s) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s x. Rep (WalletCheckpoint s) x -> WalletCheckpoint s
forall s x. WalletCheckpoint s -> Rep (WalletCheckpoint s) x
$cto :: forall s x. Rep (WalletCheckpoint s) x -> WalletCheckpoint s
$cfrom :: forall s x. WalletCheckpoint s -> Rep (WalletCheckpoint s) x
Generic)
deriving instance AddressBookIso s => Eq (WalletCheckpoint s)
getBlockHeight :: WalletCheckpoint s -> Word32
getBlockHeight :: WalletCheckpoint s -> Word32
getBlockHeight (WalletCheckpoint BlockHeader
currentTip UTxO
_ Discoveries s
_) =
BlockHeader
currentTip BlockHeader
-> ((Word32 -> Const Word32 Word32)
-> BlockHeader -> Const Word32 BlockHeader)
-> Word32
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (IsLabel
"blockHeight"
((Quantity "block" Word32
-> Const Word32 (Quantity "block" Word32))
-> BlockHeader -> Const Word32 BlockHeader)
(Quantity "block" Word32 -> Const Word32 (Quantity "block" Word32))
-> BlockHeader -> Const Word32 BlockHeader
#blockHeight ((Quantity "block" Word32
-> Const Word32 (Quantity "block" Word32))
-> BlockHeader -> Const Word32 BlockHeader)
-> ((Word32 -> Const Word32 Word32)
-> Quantity "block" Word32
-> Const Word32 (Quantity "block" Word32))
-> (Word32 -> Const Word32 Word32)
-> BlockHeader
-> Const Word32 BlockHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
"getQuantity"
((Word32 -> Const Word32 Word32)
-> Quantity "block" Word32
-> Const Word32 (Quantity "block" Word32))
(Word32 -> Const Word32 Word32)
-> Quantity "block" Word32
-> Const Word32 (Quantity "block" Word32)
#getQuantity)
getSlot :: WalletCheckpoint s -> W.Slot
getSlot :: WalletCheckpoint s -> Slot
getSlot (WalletCheckpoint BlockHeader
currentTip UTxO
_ Discoveries s
_) =
ChainPoint -> Slot
W.toSlot (ChainPoint -> Slot)
-> (BlockHeader -> ChainPoint) -> BlockHeader -> Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> ChainPoint
W.chainPointFromBlockHeader (BlockHeader -> Slot) -> BlockHeader -> Slot
forall a b. (a -> b) -> a -> b
$ BlockHeader
currentTip
toWallet :: AddressBookIso s => Prologue s -> WalletCheckpoint s -> W.Wallet s
toWallet :: Prologue s -> WalletCheckpoint s -> Wallet s
toWallet Prologue s
pro (WalletCheckpoint BlockHeader
pt UTxO
utxo Discoveries s
dis) =
UTxO -> BlockHeader -> s -> Wallet s
forall s. UTxO -> BlockHeader -> s -> Wallet s
W.unsafeInitWallet UTxO
utxo BlockHeader
pt (s -> Wallet s) -> s -> Wallet s
forall a b. (a -> b) -> a -> b
$ Iso s s (Prologue s, Discoveries s) (Prologue s, Discoveries s)
-> ((s -> (Prologue s, Discoveries s))
-> ((Prologue s, Discoveries s) -> s) -> s)
-> s
forall s t a b r. Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
withIso forall s. AddressBookIso s => Iso' s (Prologue s, Discoveries s)
Iso s s (Prologue s, Discoveries s) (Prologue s, Discoveries s)
addressIso (((s -> (Prologue s, Discoveries s))
-> ((Prologue s, Discoveries s) -> s) -> s)
-> s)
-> ((s -> (Prologue s, Discoveries s))
-> ((Prologue s, Discoveries s) -> s) -> s)
-> s
forall a b. (a -> b) -> a -> b
$ \s -> (Prologue s, Discoveries s)
_ (Prologue s, Discoveries s) -> s
from -> (Prologue s, Discoveries s) -> s
from (Prologue s
pro,Discoveries s
dis)
fromWallet :: AddressBookIso s => W.Wallet s -> (Prologue s, WalletCheckpoint s)
fromWallet :: Wallet s -> (Prologue s, WalletCheckpoint s)
fromWallet Wallet s
w = (Prologue s
pro, BlockHeader -> UTxO -> Discoveries s -> WalletCheckpoint s
forall s.
BlockHeader -> UTxO -> Discoveries s -> WalletCheckpoint s
WalletCheckpoint (Wallet s -> BlockHeader
forall s. Wallet s -> BlockHeader
W.currentTip Wallet s
w) (Wallet s -> UTxO
forall s. Wallet s -> UTxO
W.utxo Wallet s
w) Discoveries s
dis)
where
(Prologue s
pro, Discoveries s
dis) = Iso s s (Prologue s, Discoveries s) (Prologue s, Discoveries s)
-> ((s -> (Prologue s, Discoveries s))
-> ((Prologue s, Discoveries s) -> s)
-> (Prologue s, Discoveries s))
-> (Prologue s, Discoveries s)
forall s t a b r. Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
withIso forall s. AddressBookIso s => Iso' s (Prologue s, Discoveries s)
Iso s s (Prologue s, Discoveries s) (Prologue s, Discoveries s)
addressIso (((s -> (Prologue s, Discoveries s))
-> ((Prologue s, Discoveries s) -> s)
-> (Prologue s, Discoveries s))
-> (Prologue s, Discoveries s))
-> ((s -> (Prologue s, Discoveries s))
-> ((Prologue s, Discoveries s) -> s)
-> (Prologue s, Discoveries s))
-> (Prologue s, Discoveries s)
forall a b. (a -> b) -> a -> b
$ \s -> (Prologue s, Discoveries s)
to (Prologue s, Discoveries s) -> s
_ -> s -> (Prologue s, Discoveries s)
to (Wallet s
w Wallet s
-> ((s -> Const s s) -> Wallet s -> Const s (Wallet s)) -> s
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
"getState" ((s -> Const s s) -> Wallet s -> Const s (Wallet s))
(s -> Const s s) -> Wallet s -> Const s (Wallet s)
#getState)
data WalletState s = WalletState
{ WalletState s -> Prologue s
prologue :: !(Prologue s)
, WalletState s -> Checkpoints (WalletCheckpoint s)
checkpoints :: !(Checkpoints (WalletCheckpoint s))
} deriving ((forall x. WalletState s -> Rep (WalletState s) x)
-> (forall x. Rep (WalletState s) x -> WalletState s)
-> Generic (WalletState s)
forall x. Rep (WalletState s) x -> WalletState s
forall x. WalletState s -> Rep (WalletState s) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s x. Rep (WalletState s) x -> WalletState s
forall s x. WalletState s -> Rep (WalletState s) x
$cto :: forall s x. Rep (WalletState s) x -> WalletState s
$cfrom :: forall s x. WalletState s -> Rep (WalletState s) x
Generic)
deriving instance AddressBookIso s => Eq (WalletState s)
fromGenesis :: AddressBookIso s => W.Wallet s -> Maybe (WalletState s)
fromGenesis :: Wallet s -> Maybe (WalletState s)
fromGenesis Wallet s
cp
| BlockHeader -> Bool
W.isGenesisBlockHeader BlockHeader
header = WalletState s -> Maybe (WalletState s)
forall a. a -> Maybe a
Just (WalletState s -> Maybe (WalletState s))
-> WalletState s -> Maybe (WalletState s)
forall a b. (a -> b) -> a -> b
$
WalletState :: forall s.
Prologue s -> Checkpoints (WalletCheckpoint s) -> WalletState s
WalletState{ Prologue s
prologue :: Prologue s
prologue :: Prologue s
prologue, checkpoints :: Checkpoints (WalletCheckpoint s)
checkpoints = WalletCheckpoint s -> Checkpoints (WalletCheckpoint s)
forall a. a -> Checkpoints a
CPS.fromGenesis WalletCheckpoint s
checkpoint }
| Bool
otherwise = Maybe (WalletState s)
forall a. Maybe a
Nothing
where
header :: BlockHeader
header = Wallet s
cp Wallet s
-> ((BlockHeader -> Const BlockHeader BlockHeader)
-> Wallet s -> Const BlockHeader (Wallet s))
-> BlockHeader
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
"currentTip"
((BlockHeader -> Const BlockHeader BlockHeader)
-> Wallet s -> Const BlockHeader (Wallet s))
(BlockHeader -> Const BlockHeader BlockHeader)
-> Wallet s -> Const BlockHeader (Wallet s)
#currentTip
(Prologue s
prologue, WalletCheckpoint s
checkpoint) = Wallet s -> (Prologue s, WalletCheckpoint s)
forall s.
AddressBookIso s =>
Wallet s -> (Prologue s, WalletCheckpoint s)
fromWallet Wallet s
cp
getLatest :: AddressBookIso s => WalletState s -> W.Wallet s
getLatest :: WalletState s -> Wallet s
getLatest WalletState s
w =
Prologue s -> WalletCheckpoint s -> Wallet s
forall s.
AddressBookIso s =>
Prologue s -> WalletCheckpoint s -> Wallet s
toWallet (WalletState s
w WalletState s
-> ((Prologue s -> Const (Prologue s) (Prologue s))
-> WalletState s -> Const (Prologue s) (WalletState s))
-> Prologue s
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
"prologue"
((Prologue s -> Const (Prologue s) (Prologue s))
-> WalletState s -> Const (Prologue s) (WalletState s))
(Prologue s -> Const (Prologue s) (Prologue s))
-> WalletState s -> Const (Prologue s) (WalletState s)
#prologue) (WalletCheckpoint s -> Wallet s)
-> ((Slot, WalletCheckpoint s) -> WalletCheckpoint s)
-> (Slot, WalletCheckpoint s)
-> Wallet s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Slot, WalletCheckpoint s) -> WalletCheckpoint s
forall a b. (a, b) -> b
snd ((Slot, WalletCheckpoint s) -> Wallet s)
-> (Slot, WalletCheckpoint s) -> Wallet s
forall a b. (a -> b) -> a -> b
$ Checkpoints (WalletCheckpoint s) -> (Slot, WalletCheckpoint s)
forall a. Checkpoints a -> (Slot, a)
CPS.getLatest (WalletState s
w WalletState s
-> ((Checkpoints (WalletCheckpoint s)
-> Const
(Checkpoints (WalletCheckpoint s))
(Checkpoints (WalletCheckpoint s)))
-> WalletState s
-> Const (Checkpoints (WalletCheckpoint s)) (WalletState s))
-> Checkpoints (WalletCheckpoint s)
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
"checkpoints"
((Checkpoints (WalletCheckpoint s)
-> Const
(Checkpoints (WalletCheckpoint s))
(Checkpoints (WalletCheckpoint s)))
-> WalletState s
-> Const (Checkpoints (WalletCheckpoint s)) (WalletState s))
(Checkpoints (WalletCheckpoint s)
-> Const
(Checkpoints (WalletCheckpoint s))
(Checkpoints (WalletCheckpoint s)))
-> WalletState s
-> Const (Checkpoints (WalletCheckpoint s)) (WalletState s)
#checkpoints)
findNearestPoint :: WalletState s -> W.Slot -> Maybe W.Slot
findNearestPoint :: WalletState s -> Slot -> Maybe Slot
findNearestPoint = Checkpoints (WalletCheckpoint s) -> Slot -> Maybe Slot
forall a. Checkpoints a -> Slot -> Maybe Slot
CPS.findNearestPoint (Checkpoints (WalletCheckpoint s) -> Slot -> Maybe Slot)
-> (WalletState s -> Checkpoints (WalletCheckpoint s))
-> WalletState s
-> Slot
-> Maybe Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Checkpoints (WalletCheckpoint s)
-> Const
(Checkpoints (WalletCheckpoint s))
(Checkpoints (WalletCheckpoint s)))
-> WalletState s
-> Const (Checkpoints (WalletCheckpoint s)) (WalletState s))
-> WalletState s -> Checkpoints (WalletCheckpoint s)
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
"checkpoints"
((Checkpoints (WalletCheckpoint s)
-> Const
(Checkpoints (WalletCheckpoint s))
(Checkpoints (WalletCheckpoint s)))
-> WalletState s
-> Const (Checkpoints (WalletCheckpoint s)) (WalletState s))
(Checkpoints (WalletCheckpoint s)
-> Const
(Checkpoints (WalletCheckpoint s))
(Checkpoints (WalletCheckpoint s)))
-> WalletState s
-> Const (Checkpoints (WalletCheckpoint s)) (WalletState s)
#checkpoints
type DeltaWalletState s = [DeltaWalletState1 s]
data DeltaWalletState1 s
= ReplacePrologue (Prologue s)
| UpdateCheckpoints (CPS.DeltasCheckpoints (WalletCheckpoint s))
instance Delta (DeltaWalletState1 s) where
type Base (DeltaWalletState1 s) = WalletState s
apply :: DeltaWalletState1 s
-> Base (DeltaWalletState1 s) -> Base (DeltaWalletState1 s)
apply (ReplacePrologue Prologue s
p) = ((Prologue s -> Identity (Prologue s))
-> WalletState s -> Identity (WalletState s))
-> (Prologue s -> Prologue s) -> WalletState s -> WalletState s
forall a b s t.
((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
over IsLabel
"prologue"
((Prologue s -> Identity (Prologue s))
-> WalletState s -> Identity (WalletState s))
(Prologue s -> Identity (Prologue s))
-> WalletState s -> Identity (WalletState s)
#prologue ((Prologue s -> Prologue s) -> WalletState s -> WalletState s)
-> (Prologue s -> Prologue s) -> WalletState s -> WalletState s
forall a b. (a -> b) -> a -> b
$ Prologue s -> Prologue s -> Prologue s
forall a b. a -> b -> a
const Prologue s
p
apply (UpdateCheckpoints DeltasCheckpoints (WalletCheckpoint s)
d) = ((Checkpoints (WalletCheckpoint s)
-> Identity (Checkpoints (WalletCheckpoint s)))
-> WalletState s -> Identity (WalletState s))
-> (Checkpoints (WalletCheckpoint s)
-> Checkpoints (WalletCheckpoint s))
-> WalletState s
-> WalletState s
forall a b s t.
((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
over IsLabel
"checkpoints"
((Checkpoints (WalletCheckpoint s)
-> Identity (Checkpoints (WalletCheckpoint s)))
-> WalletState s -> Identity (WalletState s))
(Checkpoints (WalletCheckpoint s)
-> Identity (Checkpoints (WalletCheckpoint s)))
-> WalletState s -> Identity (WalletState s)
#checkpoints ((Checkpoints (WalletCheckpoint s)
-> Checkpoints (WalletCheckpoint s))
-> WalletState s -> WalletState s)
-> (Checkpoints (WalletCheckpoint s)
-> Checkpoints (WalletCheckpoint s))
-> WalletState s
-> WalletState s
forall a b. (a -> b) -> a -> b
$ DeltasCheckpoints (WalletCheckpoint s)
-> Base (DeltasCheckpoints (WalletCheckpoint s))
-> Base (DeltasCheckpoints (WalletCheckpoint s))
forall delta. Delta delta => delta -> Base delta -> Base delta
apply DeltasCheckpoints (WalletCheckpoint s)
d
instance Buildable (DeltaWalletState1 s) where
build :: DeltaWalletState1 s -> Builder
build (ReplacePrologue Prologue s
_) = Builder
"ReplacePrologue …"
build (UpdateCheckpoints DeltasCheckpoints (WalletCheckpoint s)
d) = Builder
"UpdateCheckpoints (" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> DeltasCheckpoints (WalletCheckpoint s) -> Builder
forall p. Buildable p => p -> Builder
build DeltasCheckpoints (WalletCheckpoint s)
d Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"
instance Show (DeltaWalletState1 s) where
show :: DeltaWalletState1 s -> String
show = DeltaWalletState1 s -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty
adjustNoSuchWallet
:: WalletId
-> (ErrNoSuchWallet -> e)
-> (w -> Either e (dw, b))
-> (Map WalletId w -> (Maybe (DeltaMap WalletId dw), Either e b))
adjustNoSuchWallet :: WalletId
-> (ErrNoSuchWallet -> e)
-> (w -> Either e (dw, b))
-> Map WalletId w
-> (Maybe (DeltaMap WalletId dw), Either e b)
adjustNoSuchWallet WalletId
wid ErrNoSuchWallet -> e
err w -> Either e (dw, b)
update Map WalletId w
wallets = case WalletId -> Map WalletId w -> Maybe w
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WalletId
wid Map WalletId w
wallets of
Maybe w
Nothing -> (Maybe (DeltaMap WalletId dw)
forall a. Maybe a
Nothing, e -> Either e b
forall a b. a -> Either a b
Left (e -> Either e b) -> e -> Either e b
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> e
err (ErrNoSuchWallet -> e) -> ErrNoSuchWallet -> e
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid)
Just w
wal -> case w -> Either e (dw, b)
update w
wal of
Left e
e -> (Maybe (DeltaMap WalletId dw)
forall a. Maybe a
Nothing, e -> Either e b
forall a b. a -> Either a b
Left e
e)
Right (dw
dw, b
b) -> (DeltaMap WalletId dw -> Maybe (DeltaMap WalletId dw)
forall a. a -> Maybe a
Just (DeltaMap WalletId dw -> Maybe (DeltaMap WalletId dw))
-> DeltaMap WalletId dw -> Maybe (DeltaMap WalletId dw)
forall a b. (a -> b) -> a -> b
$ WalletId -> dw -> DeltaMap WalletId dw
forall key da. key -> da -> DeltaMap key da
Adjust WalletId
wid dw
dw, b -> Either e b
forall a b. b -> Either a b
Right b
b)
newtype ErrNoSuchWallet
= ErrNoSuchWallet WalletId
deriving (ErrNoSuchWallet -> ErrNoSuchWallet -> Bool
(ErrNoSuchWallet -> ErrNoSuchWallet -> Bool)
-> (ErrNoSuchWallet -> ErrNoSuchWallet -> Bool)
-> Eq ErrNoSuchWallet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrNoSuchWallet -> ErrNoSuchWallet -> Bool
$c/= :: ErrNoSuchWallet -> ErrNoSuchWallet -> Bool
== :: ErrNoSuchWallet -> ErrNoSuchWallet -> Bool
$c== :: ErrNoSuchWallet -> ErrNoSuchWallet -> Bool
Eq, Int -> ErrNoSuchWallet -> ShowS
[ErrNoSuchWallet] -> ShowS
ErrNoSuchWallet -> String
(Int -> ErrNoSuchWallet -> ShowS)
-> (ErrNoSuchWallet -> String)
-> ([ErrNoSuchWallet] -> ShowS)
-> Show ErrNoSuchWallet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrNoSuchWallet] -> ShowS
$cshowList :: [ErrNoSuchWallet] -> ShowS
show :: ErrNoSuchWallet -> String
$cshow :: ErrNoSuchWallet -> String
showsPrec :: Int -> ErrNoSuchWallet -> ShowS
$cshowsPrec :: Int -> ErrNoSuchWallet -> ShowS
Show)