{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-missed-specialisations #-}

module Cardano.Chain.UTxO.UTxO (
  UTxO (..),
  UTxOError (..),
  empty,
  fromList,
  fromBalances,
  fromTxOut,
  toList,
  member,
  lookup,
  lookupCompact,
  lookupAddress,
  union,
  concat,
  balance,
  (<|),
  (</|),
  txOutputUTxO,
  isRedeemUTxO,
)
where

import Cardano.Chain.Common (
  Address,
  Lovelace,
  LovelaceError,
  isRedeemAddress,
  sumLovelace,
 )
import Cardano.Chain.UTxO.Compact (
  CompactTxIn,
  CompactTxOut,
  fromCompactTxIn,
  fromCompactTxOut,
  toCompactTxIn,
  toCompactTxOut,
 )
import Cardano.Chain.UTxO.Tx (Tx (..), TxId, TxIn (..), TxOut (..))
import Cardano.Crypto (serializeCborHash)
import Cardano.HeapWords (HeapWords)
import Cardano.Ledger.Binary (
  DecCBOR (..),
  DecoderError (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  cborError,
  decodeListLen,
  decodeWord8,
  encodeListLen,
  fromByronCBOR,
  matchSize,
  toByronCBOR,
 )
import Cardano.Prelude hiding (cborError, concat, empty, toList)
import Data.Coerce
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import NoThunks.Class (NoThunks (..))

newtype UTxO = UTxO
  { UTxO -> Map CompactTxIn CompactTxOut
unUTxO :: Map CompactTxIn CompactTxOut
  }
  deriving (UTxO -> UTxO -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UTxO -> UTxO -> Bool
$c/= :: UTxO -> UTxO -> Bool
== :: UTxO -> UTxO -> Bool
$c== :: UTxO -> UTxO -> Bool
Eq, Int -> UTxO -> ShowS
[UTxO] -> ShowS
UTxO -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UTxO] -> ShowS
$cshowList :: [UTxO] -> ShowS
show :: UTxO -> String
$cshow :: UTxO -> String
showsPrec :: Int -> UTxO -> ShowS
$cshowsPrec :: Int -> UTxO -> ShowS
Show, forall x. Rep UTxO x -> UTxO
forall x. UTxO -> Rep UTxO x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UTxO x -> UTxO
$cfrom :: forall x. UTxO -> Rep UTxO x
Generic)
  deriving newtype (UTxO -> Int
forall a. (a -> Int) -> HeapWords a
heapWords :: UTxO -> Int
$cheapWords :: UTxO -> Int
HeapWords, Typeable UTxO
Proxy UTxO -> Text
forall s. Decoder s UTxO
forall a.
Typeable a
-> (forall s. Decoder s a)
-> (forall s. Proxy a -> Decoder s ())
-> (Proxy a -> Text)
-> DecCBOR a
forall s. Proxy UTxO -> Decoder s ()
label :: Proxy UTxO -> Text
$clabel :: Proxy UTxO -> Text
dropCBOR :: forall s. Proxy UTxO -> Decoder s ()
$cdropCBOR :: forall s. Proxy UTxO -> Decoder s ()
decCBOR :: forall s. Decoder s UTxO
$cdecCBOR :: forall s. Decoder s UTxO
DecCBOR, Typeable UTxO
UTxO -> Encoding
(forall t. EncCBOR t => Proxy t -> Size) -> Proxy [UTxO] -> Size
(forall t. EncCBOR t => Proxy t -> Size) -> Proxy UTxO -> Size
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> EncCBOR a
encodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy [UTxO] -> Size
$cencodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy [UTxO] -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy UTxO -> Size
$cencodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy UTxO -> Size
encCBOR :: UTxO -> Encoding
$cencCBOR :: UTxO -> Encoding
EncCBOR)
  deriving anyclass (UTxO -> ()
forall a. (a -> ()) -> NFData a
rnf :: UTxO -> ()
$crnf :: UTxO -> ()
NFData, Context -> UTxO -> IO (Maybe ThunkInfo)
Proxy UTxO -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy UTxO -> String
$cshowTypeOf :: Proxy UTxO -> String
wNoThunks :: Context -> UTxO -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> UTxO -> IO (Maybe ThunkInfo)
noThunks :: Context -> UTxO -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> UTxO -> IO (Maybe ThunkInfo)
NoThunks)

instance ToCBOR UTxO where
  toCBOR :: UTxO -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR UTxO where
  fromCBOR :: forall s. Decoder s UTxO
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR

data UTxOError
  = UTxOMissingInput TxIn
  | UTxOOverlappingUnion
  deriving (UTxOError -> UTxOError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UTxOError -> UTxOError -> Bool
$c/= :: UTxOError -> UTxOError -> Bool
== :: UTxOError -> UTxOError -> Bool
$c== :: UTxOError -> UTxOError -> Bool
Eq, Int -> UTxOError -> ShowS
[UTxOError] -> ShowS
UTxOError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UTxOError] -> ShowS
$cshowList :: [UTxOError] -> ShowS
show :: UTxOError -> String
$cshow :: UTxOError -> String
showsPrec :: Int -> UTxOError -> ShowS
$cshowsPrec :: Int -> UTxOError -> ShowS
Show)

instance ToCBOR UTxOError where
  toCBOR :: UTxOError -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR UTxOError where
  fromCBOR :: forall s. Decoder s UTxOError
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance EncCBOR UTxOError where
  encCBOR :: UTxOError -> Encoding
encCBOR = \case
    UTxOMissingInput TxIn
txIn ->
      Word -> Encoding
encodeListLen Word
2 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR @Word8 Word8
0 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR TxIn
txIn
    UTxOError
UTxOOverlappingUnion ->
      Word -> Encoding
encodeListLen Word
1 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR @Word8 Word8
1

instance DecCBOR UTxOError where
  decCBOR :: forall s. Decoder s UTxOError
decCBOR = do
    Int
len <- forall s. Decoder s Int
decodeListLen
    Word8
tag <- forall s. Decoder s Word8
decodeWord8
    case Word8
tag of
      Word8
0 -> forall s. Text -> Int -> Int -> Decoder s ()
matchSize Text
"UTxOError" Int
2 Int
len forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TxIn -> UTxOError
UTxOMissingInput forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
1 -> forall s. Text -> Int -> Int -> Decoder s ()
matchSize Text
"UTxOError" Int
1 Int
len forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> UTxOError
UTxOOverlappingUnion
      Word8
_ -> forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"UTxOError" Word8
tag

empty :: UTxO
empty :: UTxO
empty = Map CompactTxIn CompactTxOut -> UTxO
UTxO forall a. Monoid a => a
mempty

fromList :: [(TxIn, TxOut)] -> UTxO
fromList :: [(TxIn, TxOut)] -> UTxO
fromList = Map CompactTxIn CompactTxOut -> UTxO
UTxO forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [(TxIn, TxOut)] -> [(CompactTxIn, CompactTxOut)]
toCompactTxInTxOutList
  where
    toCompactTxInTxOutList :: [(TxIn, TxOut)] -> [(CompactTxIn, CompactTxOut)]
    toCompactTxInTxOutList :: [(TxIn, TxOut)] -> [(CompactTxIn, CompactTxOut)]
toCompactTxInTxOutList = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap TxIn -> CompactTxIn
toCompactTxIn TxOut -> CompactTxOut
toCompactTxOut)

-- | Create a 'UTxO' from a list of initial balances
fromBalances :: [(Address, Lovelace)] -> UTxO
fromBalances :: [(Address, Lovelace)] -> UTxO
fromBalances =
  forall b a. b -> Either a b -> b
fromRight (forall a. HasCallStack => Text -> a
panic Text
"fromBalances: duplicate Address in initial balances")
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *). MonadError UTxOError m => [UTxO] -> m UTxO
concat
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TxOut -> UTxO
fromTxOut forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Address -> Lovelace -> TxOut
TxOut)

-- | Construct a UTxO from a TxOut. This UTxO is a singleton with a TxIn that
-- references an address constructed by hashing the TxOut address. This means
-- it is not guaranteed (or likely) to be a real address.
fromTxOut :: TxOut -> UTxO
fromTxOut :: TxOut -> UTxO
fromTxOut TxOut
out = [(TxIn, TxOut)] -> UTxO
fromList [(TxId -> Word16 -> TxIn
TxInUtxo (coerce :: forall a b. Coercible a b => a -> b
coerce forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. EncCBOR a => a -> Hash a
serializeCborHash forall a b. (a -> b) -> a -> b
$ TxOut -> Address
txOutAddress TxOut
out) Word16
0, TxOut
out)]

toList :: UTxO -> [(TxIn, TxOut)]
toList :: UTxO -> [(TxIn, TxOut)]
toList = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap CompactTxIn -> TxIn
fromCompactTxIn CompactTxOut -> TxOut
fromCompactTxOut) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k a. Map k a -> [(k, a)]
M.toList forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTxO -> Map CompactTxIn CompactTxOut
unUTxO

member :: TxIn -> UTxO -> Bool
member :: TxIn -> UTxO -> Bool
member TxIn
txIn = forall k a. Ord k => k -> Map k a -> Bool
M.member (TxIn -> CompactTxIn
toCompactTxIn TxIn
txIn) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTxO -> Map CompactTxIn CompactTxOut
unUTxO

lookup :: TxIn -> UTxO -> Maybe TxOut
lookup :: TxIn -> UTxO -> Maybe TxOut
lookup TxIn
txIn = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CompactTxOut -> TxOut
fromCompactTxOut forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (TxIn -> CompactTxIn
toCompactTxIn TxIn
txIn) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTxO -> Map CompactTxIn CompactTxOut
unUTxO

lookupCompact :: CompactTxIn -> UTxO -> Maybe CompactTxOut
lookupCompact :: CompactTxIn -> UTxO -> Maybe CompactTxOut
lookupCompact CompactTxIn
txIn = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup CompactTxIn
txIn forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTxO -> Map CompactTxIn CompactTxOut
unUTxO

lookupAddress :: TxIn -> UTxO -> Either UTxOError Address
lookupAddress :: TxIn -> UTxO -> Either UTxOError Address
lookupAddress TxIn
txIn =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ TxIn -> UTxOError
UTxOMissingInput TxIn
txIn) (forall a b. b -> Either a b
Right forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TxOut -> Address
txOutAddress forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. CompactTxOut -> TxOut
fromCompactTxOut)
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (TxIn -> CompactTxIn
toCompactTxIn TxIn
txIn)
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTxO -> Map CompactTxIn CompactTxOut
unUTxO

union :: MonadError UTxOError m => UTxO -> UTxO -> m UTxO
union :: forall (m :: * -> *).
MonadError UTxOError m =>
UTxO -> UTxO -> m UTxO
union (UTxO Map CompactTxIn CompactTxOut
m) (UTxO Map CompactTxIn CompactTxOut
m') = do
  let m'' :: Map CompactTxIn CompactTxOut
m'' = forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map CompactTxIn CompactTxOut
m Map CompactTxIn CompactTxOut
m'
  (forall k a. Map k a -> Int
M.size Map CompactTxIn CompactTxOut
m'' forall a. Eq a => a -> a -> Bool
== forall k a. Map k a -> Int
M.size Map CompactTxIn CompactTxOut
m forall a. Num a => a -> a -> a
+ forall k a. Map k a -> Int
M.size Map CompactTxIn CompactTxOut
m') forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` UTxOError
UTxOOverlappingUnion
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map CompactTxIn CompactTxOut -> UTxO
UTxO Map CompactTxIn CompactTxOut
m''

concat :: MonadError UTxOError m => [UTxO] -> m UTxO
concat :: forall (m :: * -> *). MonadError UTxOError m => [UTxO] -> m UTxO
concat = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall (m :: * -> *).
MonadError UTxOError m =>
UTxO -> UTxO -> m UTxO
union UTxO
empty

balance :: UTxO -> Either LovelaceError Lovelace
balance :: UTxO -> Either LovelaceError Lovelace
balance = forall (t :: * -> *).
(Foldable t, Functor t) =>
t Lovelace -> Either LovelaceError Lovelace
sumLovelace forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CompactTxOut -> Lovelace
compactTxOutValue forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k a. Map k a -> [a]
M.elems forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTxO -> Map CompactTxIn CompactTxOut
unUTxO
  where
    compactTxOutValue :: CompactTxOut -> Lovelace
    compactTxOutValue :: CompactTxOut -> Lovelace
compactTxOutValue = TxOut -> Lovelace
txOutValue forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. CompactTxOut -> TxOut
fromCompactTxOut

(<|) :: Set TxIn -> UTxO -> UTxO
<| :: Set TxIn -> UTxO -> UTxO
(<|) Set TxIn
inputs = Map CompactTxIn CompactTxOut -> UTxO
UTxO forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => Map k a -> Set k -> Map k a
M.restrictKeys Set CompactTxIn
compactInputs forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTxO -> Map CompactTxIn CompactTxOut
unUTxO
  where
    compactInputs :: Set CompactTxIn
compactInputs = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map TxIn -> CompactTxIn
toCompactTxIn Set TxIn
inputs

(</|) :: Set TxIn -> UTxO -> UTxO
</| :: Set TxIn -> UTxO -> UTxO
(</|) Set TxIn
inputs = Map CompactTxIn CompactTxOut -> UTxO
UTxO forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => Map k a -> Set k -> Map k a
M.withoutKeys Set CompactTxIn
compactInputs forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTxO -> Map CompactTxIn CompactTxOut
unUTxO
  where
    compactInputs :: Set CompactTxIn
compactInputs = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map TxIn -> CompactTxIn
toCompactTxIn Set TxIn
inputs

txOutputUTxO :: Tx -> UTxO
txOutputUTxO :: Tx -> UTxO
txOutputUTxO Tx
tx =
  Map CompactTxIn CompactTxOut -> UTxO
UTxO
    forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      [ (TxIn -> CompactTxIn
toCompactTxIn (TxId -> Word16 -> TxIn
TxInUtxo (Tx -> TxId
txId Tx
tx) Word16
ix), (TxOut -> CompactTxOut
toCompactTxOut TxOut
txOut))
      | (Word16
ix, TxOut
txOut) <- [(Word16, TxOut)]
indexedOutputs
      ]
  where
    indexedOutputs :: [(Word16, TxOut)]
    indexedOutputs :: [(Word16, TxOut)]
indexedOutputs = forall a b. [a] -> [b] -> [(a, b)]
zip [Word16
0 ..] (forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ Tx -> NonEmpty TxOut
txOutputs Tx
tx)

    txId :: Tx -> TxId
    txId :: Tx -> TxId
txId = forall a. EncCBOR a => a -> Hash a
serializeCborHash

isRedeemUTxO :: UTxO -> Bool
isRedeemUTxO :: UTxO -> Bool
isRedeemUTxO =
  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Address -> Bool
isRedeemAddress forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TxOut -> Address
txOutAddress forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. CompactTxOut -> TxOut
fromCompactTxOut)
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k a. Map k a -> [a]
M.elems
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTxO -> Map CompactTxIn CompactTxOut
unUTxO