{-# 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),
  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.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 (..))

-- | 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)
  = ScriptHashObj !ScriptHash
  | KeyHashObj !(KeyHash kr)
  deriving (Int -> Credential kr -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (kr :: KeyRole). Int -> Credential kr -> ShowS
forall (kr :: KeyRole). [Credential kr] -> ShowS
forall (kr :: KeyRole). Credential kr -> String
showList :: [Credential kr] -> ShowS
$cshowList :: forall (kr :: KeyRole). [Credential kr] -> ShowS
show :: Credential kr -> String
$cshow :: forall (kr :: KeyRole). Credential kr -> String
showsPrec :: Int -> Credential kr -> ShowS
$cshowsPrec :: forall (kr :: KeyRole). Int -> Credential kr -> ShowS
Show, Credential kr -> Credential kr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (kr :: KeyRole). Credential kr -> Credential kr -> Bool
/= :: Credential kr -> Credential kr -> Bool
$c/= :: forall (kr :: KeyRole). Credential kr -> Credential kr -> Bool
== :: Credential kr -> Credential kr -> Bool
$c== :: forall (kr :: KeyRole). Credential kr -> Credential kr -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (kr :: KeyRole) x. Rep (Credential kr) x -> Credential kr
forall (kr :: KeyRole) x. Credential kr -> Rep (Credential kr) x
$cto :: forall (kr :: KeyRole) x. Rep (Credential kr) x -> Credential kr
$cfrom :: forall (kr :: KeyRole) x. Credential kr -> Rep (Credential kr) x
Generic, forall a. (a -> ()) -> NFData a
forall (kr :: KeyRole). Credential kr -> ()
rnf :: Credential kr -> ()
$crnf :: forall (kr :: KeyRole). Credential kr -> ()
NFData, Credential kr -> Credential kr -> Bool
Credential kr -> Credential kr -> 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). Eq (Credential kr)
forall (kr :: KeyRole). Credential kr -> Credential kr -> Bool
forall (kr :: KeyRole). Credential kr -> Credential kr -> Ordering
forall (kr :: KeyRole).
Credential kr -> Credential kr -> Credential kr
min :: Credential kr -> Credential kr -> Credential kr
$cmin :: forall (kr :: KeyRole).
Credential kr -> Credential kr -> Credential kr
max :: Credential kr -> Credential kr -> Credential kr
$cmax :: forall (kr :: KeyRole).
Credential kr -> Credential kr -> Credential kr
>= :: Credential kr -> Credential kr -> Bool
$c>= :: forall (kr :: KeyRole). Credential kr -> Credential kr -> Bool
> :: Credential kr -> Credential kr -> Bool
$c> :: forall (kr :: KeyRole). Credential kr -> Credential kr -> Bool
<= :: Credential kr -> Credential kr -> Bool
$c<= :: forall (kr :: KeyRole). Credential kr -> Credential kr -> Bool
< :: Credential kr -> Credential kr -> Bool
$c< :: forall (kr :: KeyRole). Credential kr -> Credential kr -> Bool
compare :: Credential kr -> Credential kr -> Ordering
$ccompare :: forall (kr :: KeyRole). Credential kr -> Credential kr -> Ordering
Ord)

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

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

instance NoThunks (Credential kr)

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

instance FromJSON (Credential kr) where
  parseJSON :: Value -> Parser (Credential kr)
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 {kr :: KeyRole}. Object -> Parser (Credential kr)
parser1 Object
obj, forall {kr :: KeyRole}. Object -> Parser (Credential kr)
parser2 Object
obj]
    where
      parser1 :: Object -> Parser (Credential kr)
parser1 Object
obj = forall (kr :: KeyRole). ScriptHash -> Credential kr
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)
parser2 Object
obj = forall (kr :: KeyRole). KeyHash kr -> Credential kr
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 ToJSONKey (Credential kr) where
  toJSONKey :: ToJSONKeyFunction (Credential kr)
toJSONKey = forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText forall (kr :: KeyRole). Credential kr -> Text
credToText

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

parseCredential ::
  MonadFail m =>
  T.Text ->
  m (Credential kr)
parseCredential :: forall (m :: * -> *) (kr :: KeyRole).
MonadFail m =>
Text -> m (Credential kr)
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). ScriptHash -> Credential kr
ScriptHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash ADDRHASH EraIndependentScript -> ScriptHash
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). KeyHash kr -> Credential kr
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: KeyRole).
Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash r
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 -> T.Text
credToText :: forall (kr :: KeyRole). Credential kr -> Text
credToText (ScriptHashObj (ScriptHash Hash ADDRHASH EraIndependentScript
hash)) = Text
"scriptHash-" forall a. Semigroup a => a -> a -> a
<> forall h a. Hash h a -> Text
hashToTextAsHex Hash ADDRHASH EraIndependentScript
hash
credToText (KeyHashObj (KeyHash Hash ADDRHASH (VerKeyDSIGN DSIGN)
has)) = Text
"keyHash-" forall a. Semigroup a => a -> a -> a
<> forall h a. Hash h a -> Text
hashToTextAsHex Hash ADDRHASH (VerKeyDSIGN DSIGN)
has

type PaymentCredential = Credential 'Payment

type StakeCredential = Credential 'Staking

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

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

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

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

instance NoThunks StakeReference

-- 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 => EncCBOR (Credential kr)

instance Typeable kr => DecCBOR (Credential kr)

instance Typeable kr => ToCBOR (Credential kr) where
  toCBOR :: Credential kr -> Encoding
toCBOR = \case
    KeyHashObj KeyHash kr
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
kh
    ScriptHashObj ScriptHash
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
hs

instance Typeable kr => FromCBOR (Credential kr) where
  fromCBOR :: forall s. Decoder s (Credential kr)
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
x <- forall a s. FromCBOR a => Decoder s a
fromCBOR
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash kr
x)
      Word
1 -> do
        ScriptHash
x <- forall a s. FromCBOR a => Decoder s a
fromCBOR
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
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