{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DerivingVia       #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}

module Ledger.Blockchain (
    OnChainTx(..),
    _Valid,
    _Invalid,
    Block,
    BlockId(..),
    Blockchain,
    Context(..),
    eitherTx,
    unOnChain,
    onChainTxIsValid,
    consumableInputs,
    outputsProduced,
    transaction,
    out,
    value,
    unspentOutputsTx,
    spentOutputs,
    unspentOutputs,
    datumTxo,
    updateUtxo,
    txOutPubKey,
    pubKeyTxo,
    validValuesTx
    ) where

import Codec.Serialise (Serialise)
import Control.Lens (makePrisms)
import Control.Monad (join)
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson qualified as JSON
import Data.Aeson.Extras qualified as JSON
import Data.ByteString qualified as BS
import Data.Either (fromRight)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Monoid (First (..))
import Data.OpenApi qualified as OpenApi
import Data.Proxy (Proxy (..))
import Data.Text qualified as Text
import Data.Text.Encoding (decodeUtf8')
import GHC.Generics (Generic)
import Prettyprinter (Pretty (..), (<+>))

import Ledger.Tx (CardanoTx, TxId, TxIn, TxOut, TxOutRef (..), getCardanoTxCollateralInputs, getCardanoTxId,
                  getCardanoTxInputs, getCardanoTxProducedOutputs, getCardanoTxProducedReturnCollateral, spentOutputs,
                  txOutDatumHash, txOutPubKey, txOutValue, unspentOutputsTx, updateUtxo, updateUtxoCollateral,
                  validValuesTx)
import Plutus.V1.Ledger.Crypto
import Plutus.V1.Ledger.Scripts
import Plutus.V1.Ledger.Value (Value)

-- | Block identifier (usually a hash)
newtype BlockId = BlockId { BlockId -> ByteString
getBlockId :: BS.ByteString }
    deriving stock (BlockId -> BlockId -> Bool
(BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> Bool) -> Eq BlockId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockId -> BlockId -> Bool
$c/= :: BlockId -> BlockId -> Bool
== :: BlockId -> BlockId -> Bool
$c== :: BlockId -> BlockId -> Bool
Eq, Eq BlockId
Eq BlockId
-> (BlockId -> BlockId -> Ordering)
-> (BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> BlockId)
-> (BlockId -> BlockId -> BlockId)
-> Ord BlockId
BlockId -> BlockId -> Bool
BlockId -> BlockId -> Ordering
BlockId -> BlockId -> BlockId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BlockId -> BlockId -> BlockId
$cmin :: BlockId -> BlockId -> BlockId
max :: BlockId -> BlockId -> BlockId
$cmax :: BlockId -> BlockId -> BlockId
>= :: BlockId -> BlockId -> Bool
$c>= :: BlockId -> BlockId -> Bool
> :: BlockId -> BlockId -> Bool
$c> :: BlockId -> BlockId -> Bool
<= :: BlockId -> BlockId -> Bool
$c<= :: BlockId -> BlockId -> Bool
< :: BlockId -> BlockId -> Bool
$c< :: BlockId -> BlockId -> Bool
compare :: BlockId -> BlockId -> Ordering
$ccompare :: BlockId -> BlockId -> Ordering
$cp1Ord :: Eq BlockId
Ord, (forall x. BlockId -> Rep BlockId x)
-> (forall x. Rep BlockId x -> BlockId) -> Generic BlockId
forall x. Rep BlockId x -> BlockId
forall x. BlockId -> Rep BlockId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BlockId x -> BlockId
$cfrom :: forall x. BlockId -> Rep BlockId x
Generic)

instance Show BlockId where
    show :: BlockId -> String
show = Text -> String
Text.unpack (Text -> String) -> (BlockId -> Text) -> BlockId -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
JSON.encodeByteString (ByteString -> Text) -> (BlockId -> ByteString) -> BlockId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> ByteString
getBlockId

instance ToJSON BlockId where
    toJSON :: BlockId -> Value
toJSON = Text -> Value
JSON.String (Text -> Value) -> (BlockId -> Text) -> BlockId -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
JSON.encodeByteString (ByteString -> Text) -> (BlockId -> ByteString) -> BlockId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> ByteString
getBlockId

instance FromJSON BlockId where
    parseJSON :: Value -> Parser BlockId
parseJSON Value
v = ByteString -> BlockId
BlockId (ByteString -> BlockId) -> Parser ByteString -> Parser BlockId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser ByteString
JSON.decodeByteString Value
v

instance OpenApi.ToSchema BlockId where
    declareNamedSchema :: Proxy BlockId -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy BlockId
_ = Proxy String -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
OpenApi.declareNamedSchema (Proxy String
forall k (t :: k). Proxy t
Proxy @String)

instance Pretty BlockId where
    pretty :: BlockId -> Doc ann
pretty (BlockId ByteString
blockId) =
        Doc ann
"BlockId "
     Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Either UnicodeException Text -> Text
forall b a. b -> Either a b -> b
fromRight (ByteString -> Text
JSON.encodeByteString ByteString
blockId) (Either UnicodeException Text -> Text)
-> Either UnicodeException Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
blockId)

-- | A transaction on the blockchain.
-- Invalid transactions are still put on the chain to be able to collect fees.
data OnChainTx = Invalid CardanoTx | Valid CardanoTx
    deriving stock (OnChainTx -> OnChainTx -> Bool
(OnChainTx -> OnChainTx -> Bool)
-> (OnChainTx -> OnChainTx -> Bool) -> Eq OnChainTx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OnChainTx -> OnChainTx -> Bool
$c/= :: OnChainTx -> OnChainTx -> Bool
== :: OnChainTx -> OnChainTx -> Bool
$c== :: OnChainTx -> OnChainTx -> Bool
Eq, Int -> OnChainTx -> ShowS
[OnChainTx] -> ShowS
OnChainTx -> String
(Int -> OnChainTx -> ShowS)
-> (OnChainTx -> String)
-> ([OnChainTx] -> ShowS)
-> Show OnChainTx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OnChainTx] -> ShowS
$cshowList :: [OnChainTx] -> ShowS
show :: OnChainTx -> String
$cshow :: OnChainTx -> String
showsPrec :: Int -> OnChainTx -> ShowS
$cshowsPrec :: Int -> OnChainTx -> ShowS
Show, (forall x. OnChainTx -> Rep OnChainTx x)
-> (forall x. Rep OnChainTx x -> OnChainTx) -> Generic OnChainTx
forall x. Rep OnChainTx x -> OnChainTx
forall x. OnChainTx -> Rep OnChainTx x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OnChainTx x -> OnChainTx
$cfrom :: forall x. OnChainTx -> Rep OnChainTx x
Generic)
    deriving anyclass ([OnChainTx] -> Encoding
[OnChainTx] -> Value
OnChainTx -> Encoding
OnChainTx -> Value
(OnChainTx -> Value)
-> (OnChainTx -> Encoding)
-> ([OnChainTx] -> Value)
-> ([OnChainTx] -> Encoding)
-> ToJSON OnChainTx
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [OnChainTx] -> Encoding
$ctoEncodingList :: [OnChainTx] -> Encoding
toJSONList :: [OnChainTx] -> Value
$ctoJSONList :: [OnChainTx] -> Value
toEncoding :: OnChainTx -> Encoding
$ctoEncoding :: OnChainTx -> Encoding
toJSON :: OnChainTx -> Value
$ctoJSON :: OnChainTx -> Value
ToJSON, Value -> Parser [OnChainTx]
Value -> Parser OnChainTx
(Value -> Parser OnChainTx)
-> (Value -> Parser [OnChainTx]) -> FromJSON OnChainTx
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [OnChainTx]
$cparseJSONList :: Value -> Parser [OnChainTx]
parseJSON :: Value -> Parser OnChainTx
$cparseJSON :: Value -> Parser OnChainTx
FromJSON, [OnChainTx] -> Encoding
OnChainTx -> Encoding
(OnChainTx -> Encoding)
-> (forall s. Decoder s OnChainTx)
-> ([OnChainTx] -> Encoding)
-> (forall s. Decoder s [OnChainTx])
-> Serialise OnChainTx
forall s. Decoder s [OnChainTx]
forall s. Decoder s OnChainTx
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
decodeList :: Decoder s [OnChainTx]
$cdecodeList :: forall s. Decoder s [OnChainTx]
encodeList :: [OnChainTx] -> Encoding
$cencodeList :: [OnChainTx] -> Encoding
decode :: Decoder s OnChainTx
$cdecode :: forall s. Decoder s OnChainTx
encode :: OnChainTx -> Encoding
$cencode :: OnChainTx -> Encoding
Serialise)

instance Pretty OnChainTx where
    pretty :: OnChainTx -> Doc ann
pretty = \case
        Invalid CardanoTx
tx -> Doc ann
"Invalid:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CardanoTx -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CardanoTx
tx
        Valid   CardanoTx
tx -> Doc ann
"Valid:"   Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CardanoTx -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CardanoTx
tx

-- | A block on the blockchain. This is just a list of transactions
-- following on from the chain so far.
type Block = [OnChainTx]
-- | A blockchain, which is just a list of blocks, starting with the newest.
type Blockchain = [Block]

eitherTx :: (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r
eitherTx :: (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r
eitherTx CardanoTx -> r
ifInvalid CardanoTx -> r
_ (Invalid CardanoTx
tx) = CardanoTx -> r
ifInvalid CardanoTx
tx
eitherTx CardanoTx -> r
_ CardanoTx -> r
ifValid (Valid CardanoTx
tx)     = CardanoTx -> r
ifValid CardanoTx
tx

unOnChain :: OnChainTx -> CardanoTx
unOnChain :: OnChainTx -> CardanoTx
unOnChain = (CardanoTx -> CardanoTx)
-> (CardanoTx -> CardanoTx) -> OnChainTx -> CardanoTx
forall r. (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r
eitherTx CardanoTx -> CardanoTx
forall a. a -> a
id CardanoTx -> CardanoTx
forall a. a -> a
id

onChainTxIsValid :: OnChainTx -> Bool
onChainTxIsValid :: OnChainTx -> Bool
onChainTxIsValid = (CardanoTx -> Bool) -> (CardanoTx -> Bool) -> OnChainTx -> Bool
forall r. (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r
eitherTx (Bool -> CardanoTx -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> CardanoTx -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Outputs consumed from the UTXO set by the 'OnChainTx'
consumableInputs :: OnChainTx -> [TxIn]
consumableInputs :: OnChainTx -> [TxIn]
consumableInputs = (CardanoTx -> [TxIn])
-> (CardanoTx -> [TxIn]) -> OnChainTx -> [TxIn]
forall r. (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r
eitherTx CardanoTx -> [TxIn]
getCardanoTxCollateralInputs CardanoTx -> [TxIn]
getCardanoTxInputs

-- | Outputs added to the UTXO set by the 'OnChainTx'
outputsProduced :: OnChainTx -> Map TxOutRef TxOut
outputsProduced :: OnChainTx -> Map TxOutRef TxOut
outputsProduced = (CardanoTx -> Map TxOutRef TxOut)
-> (CardanoTx -> Map TxOutRef TxOut)
-> OnChainTx
-> Map TxOutRef TxOut
forall r. (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r
eitherTx CardanoTx -> Map TxOutRef TxOut
getCardanoTxProducedReturnCollateral CardanoTx -> Map TxOutRef TxOut
getCardanoTxProducedOutputs

-- | Lookup a transaction in a 'Blockchain' by its id.
transaction :: Blockchain -> TxId -> Maybe OnChainTx
transaction :: Blockchain -> TxId -> Maybe OnChainTx
transaction Blockchain
bc TxId
tid = First OnChainTx -> Maybe OnChainTx
forall a. First a -> Maybe a
getFirst (First OnChainTx -> Maybe OnChainTx)
-> (Blockchain -> First OnChainTx) -> Blockchain -> Maybe OnChainTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([OnChainTx] -> First OnChainTx) -> Blockchain -> First OnChainTx
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((OnChainTx -> First OnChainTx) -> [OnChainTx] -> First OnChainTx
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap OnChainTx -> First OnChainTx
p) (Blockchain -> Maybe OnChainTx) -> Blockchain -> Maybe OnChainTx
forall a b. (a -> b) -> a -> b
$ Blockchain
bc where
    p :: OnChainTx -> First OnChainTx
p OnChainTx
tx = if TxId
tid TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== (CardanoTx -> TxId) -> (CardanoTx -> TxId) -> OnChainTx -> TxId
forall r. (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r
eitherTx CardanoTx -> TxId
getCardanoTxId CardanoTx -> TxId
getCardanoTxId OnChainTx
tx then Maybe OnChainTx -> First OnChainTx
forall a. Maybe a -> First a
First (OnChainTx -> Maybe OnChainTx
forall a. a -> Maybe a
Just OnChainTx
tx) else First OnChainTx
forall a. Monoid a => a
mempty

-- | Determine the unspent output that an input refers to
out :: Blockchain -> TxOutRef -> Maybe TxOut
out :: Blockchain -> TxOutRef -> Maybe TxOut
out Blockchain
bc TxOutRef
o = do
    OnChainTx
tx <- Blockchain -> TxId -> Maybe OnChainTx
transaction Blockchain
bc (TxOutRef -> TxId
txOutRefId TxOutRef
o)
    TxOutRef -> Map TxOutRef TxOut -> Maybe TxOut
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxOutRef
o (Map TxOutRef TxOut -> Maybe TxOut)
-> Map TxOutRef TxOut -> Maybe TxOut
forall a b. (a -> b) -> a -> b
$ OnChainTx -> Map TxOutRef TxOut
outputsProduced OnChainTx
tx

-- | Determine the unspent value that a transaction output refers to.
value :: Blockchain -> TxOutRef -> Maybe Value
value :: Blockchain -> TxOutRef -> Maybe Value
value Blockchain
bc TxOutRef
o = TxOut -> Value
txOutValue (TxOut -> Value) -> Maybe TxOut -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blockchain -> TxOutRef -> Maybe TxOut
out Blockchain
bc TxOutRef
o

-- | Determine the data script that a transaction output refers to.
datumTxo :: Blockchain -> TxOutRef -> Maybe DatumHash
datumTxo :: Blockchain -> TxOutRef -> Maybe DatumHash
datumTxo Blockchain
bc TxOutRef
o = TxOut -> Maybe DatumHash
txOutDatumHash (TxOut -> Maybe DatumHash) -> Maybe TxOut -> Maybe DatumHash
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Blockchain -> TxOutRef -> Maybe TxOut
out Blockchain
bc TxOutRef
o

-- | Determine the public key that locks a transaction output, if there is one.
pubKeyTxo :: Blockchain -> TxOutRef -> Maybe PubKeyHash
pubKeyTxo :: Blockchain -> TxOutRef -> Maybe PubKeyHash
pubKeyTxo Blockchain
bc TxOutRef
o = Blockchain -> TxOutRef -> Maybe TxOut
out Blockchain
bc TxOutRef
o Maybe TxOut -> (TxOut -> Maybe PubKeyHash) -> Maybe PubKeyHash
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TxOut -> Maybe PubKeyHash
txOutPubKey

-- | The unspent transaction outputs of the ledger as a whole.
unspentOutputs :: Blockchain -> Map TxOutRef TxOut
unspentOutputs :: Blockchain -> Map TxOutRef TxOut
unspentOutputs = (OnChainTx -> Map TxOutRef TxOut -> Map TxOutRef TxOut)
-> Map TxOutRef TxOut -> [OnChainTx] -> Map TxOutRef TxOut
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((CardanoTx -> Map TxOutRef TxOut -> Map TxOutRef TxOut)
-> (CardanoTx -> Map TxOutRef TxOut -> Map TxOutRef TxOut)
-> OnChainTx
-> Map TxOutRef TxOut
-> Map TxOutRef TxOut
forall r. (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r
eitherTx CardanoTx -> Map TxOutRef TxOut -> Map TxOutRef TxOut
updateUtxoCollateral CardanoTx -> Map TxOutRef TxOut -> Map TxOutRef TxOut
updateUtxo) Map TxOutRef TxOut
forall k a. Map k a
Map.empty ([OnChainTx] -> Map TxOutRef TxOut)
-> (Blockchain -> [OnChainTx]) -> Blockchain -> Map TxOutRef TxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blockchain -> [OnChainTx]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join

makePrisms ''OnChainTx