{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}

module Cardano.Ledger.Credential (
  Credential (KeyHashObj, ScriptHashObj),
  GenesisCredential (..),
  PaymentCredential,
  credKeyHash,
  credKeyHashWitness,
  credScriptHash,
  credToText,
  parseCredential,
  Ptr (Ptr),
  ptrSlotNo,
  ptrTxIx,
  ptrCertIx,
  StakeCredential,
  StakeReference (..),
  normalizePtr,
)
where

import Cardano.Crypto.Hash (hashFromTextAsHex, hashToTextAsHex)
import Cardano.Ledger.BaseTypes (CertIx (..), SlotNo (..), TxIx (..))
import Cardano.Ledger.Binary (
  CBORGroup (..),
  DecCBOR (..),
  DecCBORGroup (..),
  EncCBOR (..),
  EncCBORGroup (..),
  FromCBOR (..),
  ToCBOR (..),
 )
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.Hashes (ScriptHash (..))
import Cardano.Ledger.Keys (
  HasKeyRole (..),
  KeyHash (..),
  KeyRole (..),
  asWitness,
 )
import Control.Applicative ((<|>))
import Control.DeepSeq (NFData)
import Data.Aeson (
  FromJSON (..),
  FromJSONKey (..),
  FromJSONKeyFunction (..),
  KeyValue,
  ToJSON,
  ToJSONKey (..),
  object,
  pairs,
  (.:),
  (.=),
 )
import qualified Data.Aeson as Aeson
import Data.Aeson.Types (toJSONKeyText)
import Data.Default (Default (..))
import Data.Foldable (asum)
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Data.Word
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Quiet (Quiet (Quiet))

-- | Script hash or key hash for a payment or a staking object.
--
-- Note that credentials (unlike raw key hashes) do appear to vary from era to
-- era, since they reference the hash of a script, which can change. This
-- parameter is a phantom, however, so in actuality the instances will remain
-- the same.
data Credential (kr :: KeyRole) c
  = ScriptHashObj !(ScriptHash c)
  | KeyHashObj !(KeyHash kr c)
  deriving (Int -> Credential kr c -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (kr :: KeyRole) c. Int -> Credential kr c -> ShowS
forall (kr :: KeyRole) c. [Credential kr c] -> ShowS
forall (kr :: KeyRole) c. Credential kr c -> String
showList :: [Credential kr c] -> ShowS
$cshowList :: forall (kr :: KeyRole) c. [Credential kr c] -> ShowS
show :: Credential kr c -> String
$cshow :: forall (kr :: KeyRole) c. Credential kr c -> String
showsPrec :: Int -> Credential kr c -> ShowS
$cshowsPrec :: forall (kr :: KeyRole) c. Int -> Credential kr c -> ShowS
Show, Credential kr c -> Credential kr c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (kr :: KeyRole) c.
Credential kr c -> Credential kr c -> Bool
/= :: Credential kr c -> Credential kr c -> Bool
$c/= :: forall (kr :: KeyRole) c.
Credential kr c -> Credential kr c -> Bool
== :: Credential kr c -> Credential kr c -> Bool
$c== :: forall (kr :: KeyRole) c.
Credential kr c -> Credential kr c -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (kr :: KeyRole) c x.
Rep (Credential kr c) x -> Credential kr c
forall (kr :: KeyRole) c x.
Credential kr c -> Rep (Credential kr c) x
$cto :: forall (kr :: KeyRole) c x.
Rep (Credential kr c) x -> Credential kr c
$cfrom :: forall (kr :: KeyRole) c x.
Credential kr c -> Rep (Credential kr c) x
Generic, forall a. (a -> ()) -> NFData a
forall (kr :: KeyRole) c. Credential kr c -> ()
rnf :: Credential kr c -> ()
$crnf :: forall (kr :: KeyRole) c. Credential kr c -> ()
NFData, Credential kr c -> Credential kr c -> Bool
Credential kr c -> Credential kr c -> Ordering
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
forall (kr :: KeyRole) c. Eq (Credential kr c)
forall (kr :: KeyRole) c.
Credential kr c -> Credential kr c -> Bool
forall (kr :: KeyRole) c.
Credential kr c -> Credential kr c -> Ordering
forall (kr :: KeyRole) c.
Credential kr c -> Credential kr c -> Credential kr c
min :: Credential kr c -> Credential kr c -> Credential kr c
$cmin :: forall (kr :: KeyRole) c.
Credential kr c -> Credential kr c -> Credential kr c
max :: Credential kr c -> Credential kr c -> Credential kr c
$cmax :: forall (kr :: KeyRole) c.
Credential kr c -> Credential kr c -> Credential kr c
>= :: Credential kr c -> Credential kr c -> Bool
$c>= :: forall (kr :: KeyRole) c.
Credential kr c -> Credential kr c -> Bool
> :: Credential kr c -> Credential kr c -> Bool
$c> :: forall (kr :: KeyRole) c.
Credential kr c -> Credential kr c -> Bool
<= :: Credential kr c -> Credential kr c -> Bool
$c<= :: forall (kr :: KeyRole) c.
Credential kr c -> Credential kr c -> Bool
< :: Credential kr c -> Credential kr c -> Bool
$c< :: forall (kr :: KeyRole) c.
Credential kr c -> Credential kr c -> Bool
compare :: Credential kr c -> Credential kr c -> Ordering
$ccompare :: forall (kr :: KeyRole) c.
Credential kr c -> Credential kr c -> Ordering
Ord)

instance Crypto e => Default (Credential r e) where
  def :: Credential r e
def = forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall a. Default a => a
def

instance HasKeyRole Credential where
  coerceKeyRole :: forall (r :: KeyRole) c (r' :: KeyRole).
Credential r c -> Credential r' c
coerceKeyRole (ScriptHashObj ScriptHash c
x) = forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash c
x
  coerceKeyRole (KeyHashObj KeyHash r c
x) = forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall a b. (a -> b) -> a -> b
$ forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole KeyHash r c
x

instance NoThunks (Credential kr c)

instance Crypto c => ToJSON (Credential kr c) where
  toJSON :: Credential kr c -> Value
toJSON (ScriptHashObj ScriptHash c
hash) =
    [Pair] -> Value
Aeson.object
      [ Key
"scriptHash" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ScriptHash c
hash
      ]
  toJSON (KeyHashObj KeyHash kr c
hash) =
    [Pair] -> Value
Aeson.object
      [ Key
"keyHash" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= KeyHash kr c
hash
      ]

instance Crypto c => FromJSON (Credential kr c) where
  parseJSON :: Value -> Parser (Credential kr c)
parseJSON =
    forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Credential" forall a b. (a -> b) -> a -> b
$ \Object
obj ->
      forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [forall {c} {kr :: KeyRole}.
Crypto c =>
Object -> Parser (Credential kr c)
parser1 Object
obj, forall {c} {kr :: KeyRole}.
Crypto c =>
Object -> Parser (Credential kr c)
parser2 Object
obj]
    where
      parser1 :: Object -> Parser (Credential kr c)
parser1 Object
obj = forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"scriptHash" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"script hash")
      parser2 :: Object -> Parser (Credential kr c)
parser2 Object
obj = forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"keyHash" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"key hash")

instance Crypto c => ToJSONKey (Credential kr c) where
  toJSONKey :: ToJSONKeyFunction (Credential kr c)
toJSONKey = forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText forall (kr :: KeyRole) c. Credential kr c -> Text
credToText

instance Crypto c => FromJSONKey (Credential kr c) where
  fromJSONKey :: FromJSONKeyFunction (Credential kr c)
fromJSONKey = forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser forall (m :: * -> *) c (kr :: KeyRole).
(MonadFail m, Crypto c) =>
Text -> m (Credential kr c)
parseCredential

parseCredential ::
  (MonadFail m, Crypto c) =>
  T.Text ->
  m (Credential kr c)
parseCredential :: forall (m :: * -> *) c (kr :: KeyRole).
(MonadFail m, Crypto c) =>
Text -> m (Credential kr c)
parseCredential Text
t = case Text -> Text -> [Text]
T.splitOn Text
"-" Text
t of
  [Text
"scriptHash", Text
hash] ->
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
badHash Text
hash)
      (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Hash (ADDRHASH c) EraIndependentScript -> ScriptHash c
ScriptHash)
      (forall h a. HashAlgorithm h => Text -> Maybe (Hash h a)
hashFromTextAsHex Text
hash)
  [Text
"keyHash", Text
hash] ->
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
badHash Text
hash)
      (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: KeyRole) c.
Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c)) -> KeyHash r c
KeyHash)
      (forall h a. HashAlgorithm h => Text -> Maybe (Hash h a)
hashFromTextAsHex Text
hash)
  [Text]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid credential: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
t
  where
    badHash :: a -> m a
badHash a
h = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid hash: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
h

credToText :: Credential kr c -> T.Text
credToText :: forall (kr :: KeyRole) c. Credential kr c -> Text
credToText (ScriptHashObj (ScriptHash Hash (ADDRHASH c) EraIndependentScript
hash)) = Text
"scriptHash-" forall a. Semigroup a => a -> a -> a
<> forall h a. Hash h a -> Text
hashToTextAsHex Hash (ADDRHASH c) EraIndependentScript
hash
credToText (KeyHashObj (KeyHash Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c))
has)) = Text
"keyHash-" forall a. Semigroup a => a -> a -> a
<> forall h a. Hash h a -> Text
hashToTextAsHex Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c))
has

type PaymentCredential c = Credential 'Payment c

type StakeCredential c = Credential 'Staking c

credKeyHash :: Credential r c -> Maybe (KeyHash r c)
credKeyHash :: forall (r :: KeyRole) c. Credential r c -> Maybe (KeyHash r c)
credKeyHash = \case
  KeyHashObj KeyHash r c
hk -> forall a. a -> Maybe a
Just KeyHash r c
hk
  ScriptHashObj ScriptHash c
_ -> forall a. Maybe a
Nothing

-- | Convert a KeyHash into a Witness KeyHash. Does nothing for Script credentials.
credKeyHashWitness :: Credential r c -> Maybe (KeyHash 'Witness c)
credKeyHashWitness :: forall (r :: KeyRole) c.
Credential r c -> Maybe (KeyHash 'Witness c)
credKeyHashWitness = forall (r :: KeyRole) c. Credential r c -> Maybe (KeyHash r c)
credKeyHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness

-- | Extract ScriptHash from a Credential. Returns Nothing for KeyHashes
credScriptHash :: Credential kr c -> Maybe (ScriptHash c)
credScriptHash :: forall (kr :: KeyRole) c. Credential kr c -> Maybe (ScriptHash c)
credScriptHash = \case
  ScriptHashObj ScriptHash c
hs -> forall a. a -> Maybe a
Just ScriptHash c
hs
  KeyHashObj KeyHash kr c
_ -> forall a. Maybe a
Nothing

data StakeReference c
  = StakeRefBase !(StakeCredential c)
  | StakeRefPtr !Ptr
  | StakeRefNull
  deriving (Int -> StakeReference c -> ShowS
forall c. Int -> StakeReference c -> ShowS
forall c. [StakeReference c] -> ShowS
forall c. StakeReference c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StakeReference c] -> ShowS
$cshowList :: forall c. [StakeReference c] -> ShowS
show :: StakeReference c -> String
$cshow :: forall c. StakeReference c -> String
showsPrec :: Int -> StakeReference c -> ShowS
$cshowsPrec :: forall c. Int -> StakeReference c -> ShowS
Show, StakeReference c -> StakeReference c -> Bool
forall c. StakeReference c -> StakeReference c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StakeReference c -> StakeReference c -> Bool
$c/= :: forall c. StakeReference c -> StakeReference c -> Bool
== :: StakeReference c -> StakeReference c -> Bool
$c== :: forall c. StakeReference c -> StakeReference c -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (StakeReference c) x -> StakeReference c
forall c x. StakeReference c -> Rep (StakeReference c) x
$cto :: forall c x. Rep (StakeReference c) x -> StakeReference c
$cfrom :: forall c x. StakeReference c -> Rep (StakeReference c) x
Generic, forall c. StakeReference c -> ()
forall a. (a -> ()) -> NFData a
rnf :: StakeReference c -> ()
$crnf :: forall c. StakeReference c -> ()
NFData, StakeReference c -> StakeReference c -> Bool
StakeReference c -> StakeReference c -> Ordering
forall c. Eq (StakeReference c)
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
forall c. StakeReference c -> StakeReference c -> Bool
forall c. StakeReference c -> StakeReference c -> Ordering
forall c. StakeReference c -> StakeReference c -> StakeReference c
min :: StakeReference c -> StakeReference c -> StakeReference c
$cmin :: forall c. StakeReference c -> StakeReference c -> StakeReference c
max :: StakeReference c -> StakeReference c -> StakeReference c
$cmax :: forall c. StakeReference c -> StakeReference c -> StakeReference c
>= :: StakeReference c -> StakeReference c -> Bool
$c>= :: forall c. StakeReference c -> StakeReference c -> Bool
> :: StakeReference c -> StakeReference c -> Bool
$c> :: forall c. StakeReference c -> StakeReference c -> Bool
<= :: StakeReference c -> StakeReference c -> Bool
$c<= :: forall c. StakeReference c -> StakeReference c -> Bool
< :: StakeReference c -> StakeReference c -> Bool
$c< :: forall c. StakeReference c -> StakeReference c -> Bool
compare :: StakeReference c -> StakeReference c -> Ordering
$ccompare :: forall c. StakeReference c -> StakeReference c -> Ordering
Ord)

instance NoThunks (StakeReference c)

deriving instance Crypto c => ToJSON (StakeReference c)

-- TODO: implement this optimization:
-- We expect that `SlotNo` will fit into `Word32` for a very long time,
-- because we can assume that the rate at which it is incremented isn't going to
-- increase in the near future. Therefore with current rate we should be fine for
-- another 134 years. I suggest to remove this optimization in about a
-- hundred years or thereabouts, so around a year 2122 would be good.
--
-- Compaction works in a following manner. Total 8 bytes: first 4 bytes are for
-- SlotNo (s0-s3), followed by 2 bytes for CertIx (c0-c1) and 2 more bytes for TxIx (t0-t1).
--
-- @@@
--
-- ┏━━┯━━┯━━┯━━┯━━┯━━┯━━┯━━┓
-- ┃s3 s2 s1 s0┊c1 c0┊t1 t0┃
-- ┗━━┷━━┷━━┷━━┷━━┷━━┷━━┷━━┛
--
-- @@@
-- newtype Ptr = PtrCompact Word64

-- | Pointer to a slot number, transaction index and an index in certificate
-- list.
data Ptr = Ptr !SlotNo !TxIx !CertIx
  deriving (Ptr -> Ptr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ptr -> Ptr -> Bool
$c/= :: Ptr -> Ptr -> Bool
== :: Ptr -> Ptr -> Bool
$c== :: Ptr -> Ptr -> Bool
Eq, Eq Ptr
Ptr -> Ptr -> Bool
Ptr -> Ptr -> Ordering
Ptr -> Ptr -> Ptr
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 :: Ptr -> Ptr -> Ptr
$cmin :: Ptr -> Ptr -> Ptr
max :: Ptr -> Ptr -> Ptr
$cmax :: Ptr -> Ptr -> Ptr
>= :: Ptr -> Ptr -> Bool
$c>= :: Ptr -> Ptr -> Bool
> :: Ptr -> Ptr -> Bool
$c> :: Ptr -> Ptr -> Bool
<= :: Ptr -> Ptr -> Bool
$c<= :: Ptr -> Ptr -> Bool
< :: Ptr -> Ptr -> Bool
$c< :: Ptr -> Ptr -> Bool
compare :: Ptr -> Ptr -> Ordering
$ccompare :: Ptr -> Ptr -> Ordering
Ord, forall x. Rep Ptr x -> Ptr
forall x. Ptr -> Rep Ptr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Ptr x -> Ptr
$cfrom :: forall x. Ptr -> Rep Ptr x
Generic, Ptr -> ()
forall a. (a -> ()) -> NFData a
rnf :: Ptr -> ()
$crnf :: Ptr -> ()
NFData, Context -> Ptr -> IO (Maybe ThunkInfo)
Proxy Ptr -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy Ptr -> String
$cshowTypeOf :: Proxy Ptr -> String
wNoThunks :: Context -> Ptr -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Ptr -> IO (Maybe ThunkInfo)
noThunks :: Context -> Ptr -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> Ptr -> IO (Maybe ThunkInfo)
NoThunks)
  deriving (Typeable Ptr
Ptr -> Encoding
(forall t. EncCBOR t => Proxy t -> Size) -> Proxy [Ptr] -> Size
(forall t. EncCBOR t => Proxy t -> Size) -> Proxy Ptr -> 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 [Ptr] -> Size
$cencodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy [Ptr] -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy Ptr -> Size
$cencodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy Ptr -> Size
encCBOR :: Ptr -> Encoding
$cencCBOR :: Ptr -> Encoding
EncCBOR, Typeable Ptr
Proxy Ptr -> Text
forall s. Decoder s Ptr
forall a.
Typeable a
-> (forall s. Decoder s a)
-> (forall s. Proxy a -> Decoder s ())
-> (Proxy a -> Text)
-> DecCBOR a
forall s. Proxy Ptr -> Decoder s ()
label :: Proxy Ptr -> Text
$clabel :: Proxy Ptr -> Text
dropCBOR :: forall s. Proxy Ptr -> Decoder s ()
$cdropCBOR :: forall s. Proxy Ptr -> Decoder s ()
decCBOR :: forall s. Decoder s Ptr
$cdecCBOR :: forall s. Decoder s Ptr
DecCBOR) via CBORGroup Ptr

-- | Convert any invalid `Ptr` to a `Ptr` that contains all zeros for its fields. Any
-- pointer that contains a `SlotNo`, `TxIx` or `CertIx` that is too large to fit into
-- `Word32`, `Word16` and `Word16` respectively is considered to be an invalid
-- `Ptr`. Valid `Ptr`s will be returned unmodified.
--
-- /Note/ - This is in no way related to dangling pointers, with an exception that any
-- invalid `Ptr` is guarateed to be a dangling `Ptr`.
normalizePtr :: Ptr -> Ptr
normalizePtr :: Ptr -> Ptr
normalizePtr ptr :: Ptr
ptr@(Ptr (SlotNo Word64
slotNo) (TxIx Word64
txIx) (CertIx Word64
certIx))
  | Word64
slotNo forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word32)
      Bool -> Bool -> Bool
|| Word64
txIx forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word16)
      Bool -> Bool -> Bool
|| Word64
certIx forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word16) =
      SlotNo -> TxIx -> CertIx -> Ptr
Ptr (Word64 -> SlotNo
SlotNo Word64
0) (Word64 -> TxIx
TxIx Word64
0) (Word64 -> CertIx
CertIx Word64
0)
  | Bool
otherwise = Ptr
ptr

instance ToCBOR Ptr where
  toCBOR :: Ptr -> Encoding
toCBOR (Ptr SlotNo
slotNo TxIx
txIx CertIx
certIx) = forall a. ToCBOR a => a -> Encoding
toCBOR (SlotNo
slotNo, TxIx
txIx, CertIx
certIx)

instance FromCBOR Ptr where
  fromCBOR :: forall s. Decoder s Ptr
fromCBOR = do
    (SlotNo
slotNo, TxIx
txIx, CertIx
certIx) <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SlotNo -> TxIx -> CertIx -> Ptr
Ptr SlotNo
slotNo TxIx
txIx CertIx
certIx

instance ToJSON Ptr where
  toJSON :: Ptr -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. KeyValue e a => Ptr -> [a]
toPtrPair
  toEncoding :: Ptr -> 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. KeyValue e a => Ptr -> [a]
toPtrPair

instance ToJSONKey Ptr

toPtrPair :: KeyValue e a => Ptr -> [a]
toPtrPair :: forall e a. KeyValue e a => Ptr -> [a]
toPtrPair (Ptr SlotNo
slotNo TxIx
txIndex CertIx
certIndex) =
  [ Key
"slot" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SlotNo
slotNo
  , Key
"txIndex" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TxIx
txIndex
  , Key
"certIndex" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= CertIx
certIndex
  ]

instance Show Ptr where
  showsPrec :: Int -> Ptr -> ShowS
showsPrec Int
n (Ptr SlotNo
slotNo TxIx
txIx CertIx
certIx)
    | Int
n forall a. Ord a => a -> a -> Bool
< Int
1 = ShowS
inner
    | Bool
otherwise = (Char
'(' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
inner forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
")" forall a. [a] -> [a] -> [a]
++)
    where
      inner :: ShowS
inner =
        (String
"Ptr (" forall a. [a] -> [a] -> [a]
++)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows SlotNo
slotNo
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
") (" forall a. [a] -> [a] -> [a]
++)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows TxIx
txIx
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
") (" forall a. [a] -> [a] -> [a]
++)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows CertIx
certIx
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
')' forall a. a -> [a] -> [a]
:)

{- TODO: Uncomment this once Mainnet is ready for Ptr optimization.

-- | With this pattern synonym we can recover actual values from compacted version of `Ptr`.
pattern Ptr :: SlotNo -> TxIx -> CertIx -> Ptr
pattern Ptr slotNo txIx certIx <-
  (viewPtr -> (slotNo, txIx, certIx))

{-# COMPLETE Ptr #-}

-- | `Ptr` relies on compact representation for memory efficiency and therefore
-- it will return `Nothing` if `SlotNo` takes up more than 32 bits, which is
-- totally fine for at least another 100 years.
mkPtr :: SlotNo -> TxIx -> CertIx -> Maybe Ptr
mkPtr (SlotNo slotNo) (TxIx txIx) (CertIx certIx)
  | slotNo > fromIntegral (maxBound :: Word32) = Nothing
  | otherwise =
      Just
        $! PtrCompact
          ( (slotNo `shiftL` 32) .|. (fromIntegral txIx `shiftL` 16)
              .|. fromIntegral certIx
          )

viewPtr :: Ptr -> (SlotNo, TxIx, CertIx)
viewPtr (PtrCompact ptr) =
  (SlotNo (ptr `shiftR` 32), TxIx (fromIntegral (ptr `shiftR` 16)), CertIx (fromIntegral ptr))
-}

ptrSlotNo :: Ptr -> SlotNo
ptrSlotNo :: Ptr -> SlotNo
ptrSlotNo (Ptr SlotNo
sn TxIx
_ CertIx
_) = SlotNo
sn

ptrTxIx :: Ptr -> TxIx
ptrTxIx :: Ptr -> TxIx
ptrTxIx (Ptr SlotNo
_ TxIx
txIx CertIx
_) = TxIx
txIx

ptrCertIx :: Ptr -> CertIx
ptrCertIx :: Ptr -> CertIx
ptrCertIx (Ptr SlotNo
_ TxIx
_ CertIx
cIx) = CertIx
cIx

-- NOTE: Credential serialization is unversioned, because it is needed for node-to-client
-- communication. It would be ok to change it in the future, but that will require change
-- in consensus
instance (Typeable kr, Crypto c) => EncCBOR (Credential kr c)

instance (Typeable kr, Crypto c) => DecCBOR (Credential kr c)

instance (Typeable kr, Crypto c) => ToCBOR (Credential kr c) where
  toCBOR :: Credential kr c -> Encoding
toCBOR = \case
    KeyHashObj KeyHash kr c
kh -> Word -> Encoding
Plain.encodeListLen Word
2 forall a. Semigroup a => a -> a -> a
<> forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
0 :: Word8) forall a. Semigroup a => a -> a -> a
<> forall a. ToCBOR a => a -> Encoding
toCBOR KeyHash kr c
kh
    ScriptHashObj ScriptHash c
hs -> Word -> Encoding
Plain.encodeListLen Word
2 forall a. Semigroup a => a -> a -> a
<> forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
1 :: Word8) forall a. Semigroup a => a -> a -> a
<> forall a. ToCBOR a => a -> Encoding
toCBOR ScriptHash c
hs

instance (Typeable kr, Crypto c) => FromCBOR (Credential kr c) where
  fromCBOR :: forall s. Decoder s (Credential kr c)
fromCBOR = forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
Plain.decodeRecordSum Text
"Credential" forall a b. (a -> b) -> a -> b
$
    \case
      Word
0 -> do
        KeyHash kr c
x <- forall a s. FromCBOR a => Decoder s a
fromCBOR
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash kr c
x)
      Word
1 -> do
        ScriptHash c
x <- forall a s. FromCBOR a => Decoder s a
fromCBOR
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash c
x)
      Word
k -> forall (m :: * -> *) a. MonadFail m => Word -> m a
Plain.invalidKey Word
k

instance EncCBORGroup Ptr where
  encCBORGroup :: Ptr -> Encoding
encCBORGroup (Ptr SlotNo
sl TxIx
txIx CertIx
certIx) =
    forall a. EncCBOR a => a -> Encoding
encCBOR SlotNo
sl
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR TxIx
txIx
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR CertIx
certIx
  encodedGroupSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy Ptr -> Size
encodedGroupSizeExpr forall t. EncCBOR t => Proxy t -> Size
size_ Proxy Ptr
proxy =
    forall a.
EncCBOR a =>
(forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedSizeExpr forall t. EncCBOR t => Proxy t -> Size
size_ (Ptr -> SlotNo
ptrSlotNo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy Ptr
proxy)
      forall a. Num a => a -> a -> a
+ forall a.
EncCBOR a =>
(forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedSizeExpr forall t. EncCBOR t => Proxy t -> Size
size_ (Ptr -> TxIx
ptrTxIx forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy Ptr
proxy)
      forall a. Num a => a -> a -> a
+ forall a.
EncCBOR a =>
(forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedSizeExpr forall t. EncCBOR t => Proxy t -> Size
size_ (Ptr -> CertIx
ptrCertIx forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy Ptr
proxy)

  listLen :: Ptr -> Word
listLen Ptr
_ = Word
3
  listLenBound :: Proxy Ptr -> Word
listLenBound Proxy Ptr
_ = Word
3

instance DecCBORGroup Ptr where
  decCBORGroup :: forall s. Decoder s Ptr
decCBORGroup = do
    SlotNo
slotNo <- forall a s. DecCBOR a => Decoder s a
decCBOR
    TxIx
txIx <- forall a s. DecCBOR a => Decoder s a
decCBOR
    CertIx
certIx <- forall a s. DecCBOR a => Decoder s a
decCBOR
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SlotNo -> TxIx -> CertIx -> Ptr
Ptr SlotNo
slotNo TxIx
txIx CertIx
certIx

-- case mkPtr slotNo txIx certIx of
--   Nothing -> fail $ "SlotNo is too far into the future: " ++ show slotNo
--   Just ptr -> pure ptr

newtype GenesisCredential c = GenesisCredential
  { forall c. GenesisCredential c -> KeyHash 'Genesis c
unGenesisCredential :: KeyHash 'Genesis c
  }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (GenesisCredential c) x -> GenesisCredential c
forall c x. GenesisCredential c -> Rep (GenesisCredential c) x
$cto :: forall c x. Rep (GenesisCredential c) x -> GenesisCredential c
$cfrom :: forall c x. GenesisCredential c -> Rep (GenesisCredential c) x
Generic)
  deriving newtype (GenesisCredential c -> Encoding
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [GenesisCredential c] -> Size
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (GenesisCredential c) -> Size
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> ToCBOR a
forall {c}. Crypto c => Typeable (GenesisCredential c)
forall c. Crypto c => GenesisCredential c -> Encoding
forall c.
Crypto c =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [GenesisCredential c] -> Size
forall c.
Crypto c =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (GenesisCredential c) -> Size
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [GenesisCredential c] -> Size
$cencodedListSizeExpr :: forall c.
Crypto c =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [GenesisCredential c] -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (GenesisCredential c) -> Size
$cencodedSizeExpr :: forall c.
Crypto c =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (GenesisCredential c) -> Size
toCBOR :: GenesisCredential c -> Encoding
$ctoCBOR :: forall c. Crypto c => GenesisCredential c -> Encoding
ToCBOR, GenesisCredential c -> Encoding
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [GenesisCredential c] -> Size
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (GenesisCredential c) -> 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
forall {c}. Crypto c => Typeable (GenesisCredential c)
forall c. Crypto c => GenesisCredential c -> Encoding
forall c.
Crypto c =>
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [GenesisCredential c] -> Size
forall c.
Crypto c =>
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (GenesisCredential c) -> Size
encodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [GenesisCredential c] -> Size
$cencodedListSizeExpr :: forall c.
Crypto c =>
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [GenesisCredential c] -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (GenesisCredential c) -> Size
$cencodedSizeExpr :: forall c.
Crypto c =>
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (GenesisCredential c) -> Size
encCBOR :: GenesisCredential c -> Encoding
$cencCBOR :: forall c. Crypto c => GenesisCredential c -> Encoding
EncCBOR)
  deriving (Int -> GenesisCredential c -> ShowS
[GenesisCredential c] -> ShowS
GenesisCredential c -> String
forall c. Int -> GenesisCredential c -> ShowS
forall c. [GenesisCredential c] -> ShowS
forall c. GenesisCredential c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenesisCredential c] -> ShowS
$cshowList :: forall c. [GenesisCredential c] -> ShowS
show :: GenesisCredential c -> String
$cshow :: forall c. GenesisCredential c -> String
showsPrec :: Int -> GenesisCredential c -> ShowS
$cshowsPrec :: forall c. Int -> GenesisCredential c -> ShowS
Show) via Quiet (GenesisCredential c)

instance Ord (GenesisCredential c) where
  compare :: GenesisCredential c -> GenesisCredential c -> Ordering
compare (GenesisCredential KeyHash 'Genesis c
gh) (GenesisCredential KeyHash 'Genesis c
gh') = forall a. Ord a => a -> a -> Ordering
compare KeyHash 'Genesis c
gh KeyHash 'Genesis c
gh'

instance Eq (GenesisCredential c) where
  == :: GenesisCredential c -> GenesisCredential c -> Bool
(==) (GenesisCredential KeyHash 'Genesis c
gh) (GenesisCredential KeyHash 'Genesis c
gh') = KeyHash 'Genesis c
gh forall a. Eq a => a -> a -> Bool
== KeyHash 'Genesis c
gh'