{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Shelley.TxOut (
  ShelleyTxOut (ShelleyTxOut, TxOutCompact),

  -- * Helpers
  addrEitherShelleyTxOutL,
  valueEitherShelleyTxOutL,
) where

import qualified Cardano.Crypto.Hash as HS
import Cardano.HeapWords (HeapWords (..))
import Cardano.Ledger.Address (Addr (..), CompactAddr, compactAddr, decompactAddr)
import Cardano.Ledger.Binary (
  DecCBOR (..),
  DecShareCBOR (..),
  EncCBOR (..),
  FromCBOR (..),
  Interns (..),
  ToCBOR (..),
  decodeRecordNamed,
  encodeListLen,
 )
import Cardano.Ledger.Compactible (Compactible (CompactForm, fromCompact, toCompact))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Crypto (Crypto (ADDRHASH), StandardCrypto)
import Cardano.Ledger.Keys (KeyRole (..))
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import Cardano.Ledger.Shelley.PParams ()
import Cardano.Ledger.Val (Val)
import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))

import Control.DeepSeq (NFData (rnf))
import Data.ByteString.Short (ShortByteString, pack)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.Word (Word8)
import GHC.Stack (HasCallStack)
import Lens.Micro
import NoThunks.Class (InspectHeapNamed (..), NoThunks (..))

data ShelleyTxOut era = TxOutCompact
  { forall era. ShelleyTxOut era -> CompactAddr (EraCrypto era)
txOutCompactAddr :: {-# UNPACK #-} !(CompactAddr (EraCrypto era))
  , forall era. ShelleyTxOut era -> CompactForm (Value era)
txOutCompactValue :: !(CompactForm (Value era))
  }

instance Crypto crypto => EraTxOut (ShelleyEra crypto) where
  {-# SPECIALIZE instance EraTxOut (ShelleyEra StandardCrypto) #-}

  type TxOut (ShelleyEra crypto) = ShelleyTxOut (ShelleyEra crypto)

  mkBasicTxOut :: HasCallStack =>
Addr (EraCrypto (ShelleyEra crypto))
-> Value (ShelleyEra crypto) -> TxOut (ShelleyEra crypto)
mkBasicTxOut = forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut

  -- Calling this partial function will result in compilation error, since ByronEra has
  -- no instance for EraTxOut type class.
  upgradeTxOut :: EraTxOut (PreviousEra (ShelleyEra crypto)) =>
TxOut (PreviousEra (ShelleyEra crypto))
-> TxOut (ShelleyEra crypto)
upgradeTxOut = forall a. HasCallStack => [Char] -> a
error [Char]
"It is not possible to translate Byron TxOut with 'upgradeTxOut'"

  addrEitherTxOutL :: Lens'
  (TxOut (ShelleyEra crypto))
  (Either
     (Addr (EraCrypto (ShelleyEra crypto)))
     (CompactAddr (EraCrypto (ShelleyEra crypto))))
addrEitherTxOutL = forall era.
Lens'
  (ShelleyTxOut era)
  (Either (Addr (EraCrypto era)) (CompactAddr (EraCrypto era)))
addrEitherShelleyTxOutL
  {-# INLINE addrEitherTxOutL #-}

  valueEitherTxOutL :: Lens'
  (TxOut (ShelleyEra crypto))
  (Either
     (Value (ShelleyEra crypto))
     (CompactForm (Value (ShelleyEra crypto))))
valueEitherTxOutL = forall era.
Val (Value era) =>
Lens'
  (ShelleyTxOut era) (Either (Value era) (CompactForm (Value era)))
valueEitherShelleyTxOutL
  {-# INLINE valueEitherTxOutL #-}

  getMinCoinTxOut :: PParams (ShelleyEra crypto) -> TxOut (ShelleyEra crypto) -> Coin
getMinCoinTxOut PParams (ShelleyEra crypto)
pp TxOut (ShelleyEra crypto)
_ = PParams (ShelleyEra crypto)
pp forall s a. s -> Getting a s a -> a
^. forall era.
(EraPParams era, ProtVerAtMost era 4) =>
Lens' (PParams era) Coin
ppMinUTxOValueL

addrEitherShelleyTxOutL ::
  Lens' (ShelleyTxOut era) (Either (Addr (EraCrypto era)) (CompactAddr (EraCrypto era)))
addrEitherShelleyTxOutL :: forall era.
Lens'
  (ShelleyTxOut era)
  (Either (Addr (EraCrypto era)) (CompactAddr (EraCrypto era)))
addrEitherShelleyTxOutL =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ShelleyTxOut era -> CompactAddr (EraCrypto era)
txOutCompactAddr)
    ( \ShelleyTxOut era
txOut -> \case
        Left Addr (EraCrypto era)
addr -> ShelleyTxOut era
txOut {txOutCompactAddr :: CompactAddr (EraCrypto era)
txOutCompactAddr = forall c. Addr c -> CompactAddr c
compactAddr Addr (EraCrypto era)
addr}
        Right CompactAddr (EraCrypto era)
cAddr -> ShelleyTxOut era
txOut {txOutCompactAddr :: CompactAddr (EraCrypto era)
txOutCompactAddr = CompactAddr (EraCrypto era)
cAddr}
    )
{-# INLINE addrEitherShelleyTxOutL #-}

valueEitherShelleyTxOutL ::
  Val (Value era) => Lens' (ShelleyTxOut era) (Either (Value era) (CompactForm (Value era)))
valueEitherShelleyTxOutL :: forall era.
Val (Value era) =>
Lens'
  (ShelleyTxOut era) (Either (Value era) (CompactForm (Value era)))
valueEitherShelleyTxOutL =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ShelleyTxOut era -> CompactForm (Value era)
txOutCompactValue)
    ( \ShelleyTxOut era
txOut -> \case
        Left Value era
value ->
          ShelleyTxOut era
txOut
            { txOutCompactValue :: CompactForm (Value era)
txOutCompactValue =
                forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Illegal value in TxOut: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Value era
value) forall a b. (a -> b) -> a -> b
$ forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact Value era
value
            }
        Right CompactForm (Value era)
cValue -> ShelleyTxOut era
txOut {txOutCompactValue :: CompactForm (Value era)
txOutCompactValue = CompactForm (Value era)
cValue}
    )
{-# INLINE valueEitherShelleyTxOutL #-}

-- assume Shelley+ type address : payment addr, staking addr (same length as payment), plus 1 word overhead
instance (Era era, HeapWords (CompactForm (Value era))) => HeapWords (ShelleyTxOut era) where
  heapWords :: ShelleyTxOut era -> Int
heapWords (TxOutCompact CompactAddr (EraCrypto era)
_ CompactForm (Value era)
vl) =
    Int
3
      forall a. Num a => a -> a -> a
+ forall a. HeapWords a => a -> Int
heapWords (forall (proxy :: * -> *) era.
Crypto (EraCrypto era) =>
proxy era -> ShortByteString
packedADDRHASH (forall {k} (t :: k). Proxy t
Proxy :: Proxy era))
      forall a. Num a => a -> a -> a
+ forall a. HeapWords a => a -> Int
heapWords CompactForm (Value era)
vl

instance (Era era, Val (Value era)) => Show (ShelleyTxOut era) where
  show :: ShelleyTxOut era -> [Char]
show = forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(Era era, Val (Value era)) =>
ShelleyTxOut era -> (Addr (EraCrypto era), Value era)
viewCompactTxOut -- FIXME: showing TxOut as a tuple is just sad

deriving instance Eq (CompactForm (Value era)) => Eq (ShelleyTxOut era)

instance NFData (ShelleyTxOut era) where
  rnf :: ShelleyTxOut era -> ()
rnf = (seq :: forall a b. a -> b -> b
`seq` ())

deriving via InspectHeapNamed "TxOut" (ShelleyTxOut era) instance NoThunks (ShelleyTxOut era)

pattern ShelleyTxOut ::
  (HasCallStack, Era era, Val (Value era)) =>
  Addr (EraCrypto era) ->
  Value era ->
  ShelleyTxOut era
pattern $bShelleyTxOut :: forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
$mShelleyTxOut :: forall {r} {era}.
(HasCallStack, Era era, Val (Value era)) =>
ShelleyTxOut era
-> (Addr (EraCrypto era) -> Value era -> r) -> ((# #) -> r) -> r
ShelleyTxOut addr vl <-
  (viewCompactTxOut -> (addr, vl))
  where
    ShelleyTxOut Addr (EraCrypto era)
addr Value era
vl =
      forall era.
CompactAddr (EraCrypto era)
-> CompactForm (Value era) -> ShelleyTxOut era
TxOutCompact
        (forall c. Addr c -> CompactAddr c
compactAddr Addr (EraCrypto era)
addr)
        (forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Illegal value in TxOut: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Value era
vl) forall a b. (a -> b) -> a -> b
$ forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact Value era
vl)

{-# COMPLETE ShelleyTxOut #-}

viewCompactTxOut ::
  (Era era, Val (Value era)) => ShelleyTxOut era -> (Addr (EraCrypto era), Value era)
viewCompactTxOut :: forall era.
(Era era, Val (Value era)) =>
ShelleyTxOut era -> (Addr (EraCrypto era), Value era)
viewCompactTxOut TxOutCompact {CompactAddr (EraCrypto era)
txOutCompactAddr :: CompactAddr (EraCrypto era)
txOutCompactAddr :: forall era. ShelleyTxOut era -> CompactAddr (EraCrypto era)
txOutCompactAddr, CompactForm (Value era)
txOutCompactValue :: CompactForm (Value era)
txOutCompactValue :: forall era. ShelleyTxOut era -> CompactForm (Value era)
txOutCompactValue} =
  (forall c. (HasCallStack, Crypto c) => CompactAddr c -> Addr c
decompactAddr CompactAddr (EraCrypto era)
txOutCompactAddr, forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm (Value era)
txOutCompactValue)

instance (Era era, EncCBOR (CompactForm (Value era))) => EncCBOR (ShelleyTxOut era) where
  encCBOR :: ShelleyTxOut era -> Encoding
encCBOR (TxOutCompact CompactAddr (EraCrypto era)
addr CompactForm (Value era)
coin) =
    Word -> Encoding
encodeListLen Word
2
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR CompactAddr (EraCrypto era)
addr
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR CompactForm (Value era)
coin

instance (Era era, DecCBOR (CompactForm (Value era))) => DecCBOR (ShelleyTxOut era) where
  decCBOR :: forall s. Decoder s (ShelleyTxOut era)
decCBOR =
    forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"ShelleyTxOut" (forall a b. a -> b -> a
const Int
2) forall a b. (a -> b) -> a -> b
$ do
      CompactAddr (EraCrypto era)
cAddr <- forall a s. DecCBOR a => Decoder s a
decCBOR
      forall era.
CompactAddr (EraCrypto era)
-> CompactForm (Value era) -> ShelleyTxOut era
TxOutCompact CompactAddr (EraCrypto era)
cAddr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR

instance (Era era, DecCBOR (CompactForm (Value era))) => DecShareCBOR (ShelleyTxOut era) where
  type Share (ShelleyTxOut era) = Interns (Credential 'Staking (EraCrypto era))
  decShareCBOR :: forall s. Share (ShelleyTxOut era) -> Decoder s (ShelleyTxOut era)
decShareCBOR Share (ShelleyTxOut era)
_ = forall a s. DecCBOR a => Decoder s a
decCBOR

instance (Era era, EncCBOR (CompactForm (Value era))) => ToCBOR (ShelleyTxOut era) where
  toCBOR :: ShelleyTxOut era -> Encoding
toCBOR = forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @era

instance (Era era, DecCBOR (CompactForm (Value era))) => FromCBOR (ShelleyTxOut era) where
  fromCBOR :: forall s. Decoder s (ShelleyTxOut era)
fromCBOR = forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @era

instance (Era era, Val (Value era)) => ToJSON (ShelleyTxOut era) where
  toJSON :: ShelleyTxOut era -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a era.
(KeyValue e a, Era era, Val (Value era)) =>
ShelleyTxOut era -> [a]
toTxOutPair
  toEncoding :: ShelleyTxOut era -> Encoding
toEncoding = Series -> Encoding
pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a era.
(KeyValue e a, Era era, Val (Value era)) =>
ShelleyTxOut era -> [a]
toTxOutPair

toTxOutPair :: (KeyValue e a, Era era, Val (Value era)) => ShelleyTxOut era -> [a]
toTxOutPair :: forall e a era.
(KeyValue e a, Era era, Val (Value era)) =>
ShelleyTxOut era -> [a]
toTxOutPair (ShelleyTxOut !Addr (EraCrypto era)
addr !Value era
amount) =
  [ Key
"address" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Addr (EraCrypto era)
addr
  , Key
"amount" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value era
amount
  ]

-- a ShortByteString of the same length as the ADDRHASH
-- used to calculate heapWords
packedADDRHASH :: forall proxy era. Crypto (EraCrypto era) => proxy era -> ShortByteString
packedADDRHASH :: forall (proxy :: * -> *) era.
Crypto (EraCrypto era) =>
proxy era -> ShortByteString
packedADDRHASH proxy era
_ =
  [Word8] -> ShortByteString
pack forall a b. (a -> b) -> a -> b
$
    forall a. Int -> a -> [a]
replicate
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
1 forall a. Num a => a -> a -> a
+ Word
2 forall a. Num a => a -> a -> a
* forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> Word
HS.sizeHash (forall {k} (t :: k). Proxy t
Proxy :: Proxy (ADDRHASH (EraCrypto era)))))
      (Word8
1 :: Word8)