{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}

module Cardano.Ledger.Keys.WitVKey (
  WitVKey (WitVKey),
  witVKeyHash,
) where

import Cardano.Crypto.DSIGN.Class (
  SignedDSIGN (..),
 )
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  FixedSizeCodec (..),
  decodeRecordNamed,
  encodeListLen,
 )
import Cardano.Ledger.Hashes (
  EraIndependentTxBody,
  HASH,
  Hash,
  KeyHash (..),
  hashKey,
  hashTxBodySignature,
 )
import Cardano.Ledger.Keys.Internal (
  DSIGN,
  KeyRole (..),
  VKey (..),
  asWitness,
 )
import Control.DeepSeq
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
import qualified Data.Aeson as Aeson
import Data.Aeson.Types (Parser)
import qualified Data.ByteString.Base16 as B16
import Data.Ord (comparing)
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import NoThunks.Class (AllowThunksIn (..), NoThunks (..))

-- | Proof/Witness that a transaction is authorized by the given key holder.
data WitVKey kr = WitVKeyInternal
  { forall (kr :: KeyRole). WitVKey kr -> VKey kr
wvkKey :: !(VKey kr)
  , forall (kr :: KeyRole).
WitVKey kr -> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
wvkSignature :: !(SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody))
  , forall (kr :: KeyRole). WitVKey kr -> KeyHash Witness
wvkKeyHash :: KeyHash Witness
  -- ^ Hash of the witness vkey. We store this here to avoid repeated hashing
  --   when used in ordering.
  }
  deriving ((forall x. WitVKey kr -> Rep (WitVKey kr) x)
-> (forall x. Rep (WitVKey kr) x -> WitVKey kr)
-> Generic (WitVKey kr)
forall x. Rep (WitVKey kr) x -> WitVKey kr
forall x. WitVKey kr -> Rep (WitVKey kr) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (kr :: KeyRole) x. Rep (WitVKey kr) x -> WitVKey kr
forall (kr :: KeyRole) x. WitVKey kr -> Rep (WitVKey kr) x
$cfrom :: forall (kr :: KeyRole) x. WitVKey kr -> Rep (WitVKey kr) x
from :: forall x. WitVKey kr -> Rep (WitVKey kr) x
$cto :: forall (kr :: KeyRole) x. Rep (WitVKey kr) x -> WitVKey kr
to :: forall x. Rep (WitVKey kr) x -> WitVKey kr
Generic, Int -> WitVKey kr -> ShowS
[WitVKey kr] -> ShowS
WitVKey kr -> String
(Int -> WitVKey kr -> ShowS)
-> (WitVKey kr -> String)
-> ([WitVKey kr] -> ShowS)
-> Show (WitVKey kr)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (kr :: KeyRole). Int -> WitVKey kr -> ShowS
forall (kr :: KeyRole). [WitVKey kr] -> ShowS
forall (kr :: KeyRole). WitVKey kr -> String
$cshowsPrec :: forall (kr :: KeyRole). Int -> WitVKey kr -> ShowS
showsPrec :: Int -> WitVKey kr -> ShowS
$cshow :: forall (kr :: KeyRole). WitVKey kr -> String
show :: WitVKey kr -> String
$cshowList :: forall (kr :: KeyRole). [WitVKey kr] -> ShowS
showList :: [WitVKey kr] -> ShowS
Show, WitVKey kr -> WitVKey kr -> Bool
(WitVKey kr -> WitVKey kr -> Bool)
-> (WitVKey kr -> WitVKey kr -> Bool) -> Eq (WitVKey kr)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (kr :: KeyRole). WitVKey kr -> WitVKey kr -> Bool
$c== :: forall (kr :: KeyRole). WitVKey kr -> WitVKey kr -> Bool
== :: WitVKey kr -> WitVKey kr -> Bool
$c/= :: forall (kr :: KeyRole). WitVKey kr -> WitVKey kr -> Bool
/= :: WitVKey kr -> WitVKey kr -> Bool
Eq)

deriving via
  AllowThunksIn '["wvkKeyHash"] (WitVKey kr)
  instance
    Typeable kr => NoThunks (WitVKey kr)

instance NFData (WitVKey kr) where
  rnf :: WitVKey kr -> ()
rnf WitVKeyInternal {KeyHash Witness
wvkKeyHash :: forall (kr :: KeyRole). WitVKey kr -> KeyHash Witness
wvkKeyHash :: KeyHash Witness
wvkKeyHash} = KeyHash Witness
wvkKeyHash KeyHash Witness -> () -> ()
forall a b. a -> b -> b
`seq` ()

instance Typeable kr => Ord (WitVKey kr) where
  compare :: WitVKey kr -> WitVKey kr -> Ordering
compare WitVKey kr
x WitVKey kr
y =
    -- It is advised against comparison on keys and signatures directly,
    -- therefore we use hashes of verification keys and signatures for
    -- implementing this Ord instance. Note that we do not need to memoize the
    -- hash of a signature, like it is done with the hash of a key, because Ord
    -- instance is only used for Sets of WitVKeys and it would be a mistake to
    -- have two WitVKeys in a same Set for different transactions. Therefore
    -- comparison on signatures is unlikely to happen and is only needed for
    -- compliance with Ord laws.
    (WitVKey kr -> KeyHash Witness)
-> WitVKey kr -> WitVKey kr -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing WitVKey kr -> KeyHash Witness
forall (kr :: KeyRole). WitVKey kr -> KeyHash Witness
wvkKeyHash WitVKey kr
x WitVKey kr
y Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (WitVKey kr
 -> Hash HASH (SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)))
-> WitVKey kr -> WitVKey kr -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
-> Hash HASH (SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody))
hashTxBodySignature (SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
 -> Hash HASH (SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)))
-> (WitVKey kr
    -> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody))
-> WitVKey kr
-> Hash HASH (SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WitVKey kr -> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
forall (kr :: KeyRole).
WitVKey kr -> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
wvkSignature) WitVKey kr
x WitVKey kr
y

instance ToJSON (WitVKey kr) where
  toJSON :: WitVKey kr -> Value
toJSON (WitVKey (VKey VerKeyDSIGN DSIGN
vk) (SignedDSIGN SigDSIGN DSIGN
sig)) =
    [Pair] -> Value
Aeson.object
      [ Key
"key" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8 (ByteString -> ByteString
B16.encode (VerKeyDSIGN DSIGN -> ByteString
forall a. FixedSizeCodec a => a -> ByteString
rawEncodeFixedSized VerKeyDSIGN DSIGN
vk))
      , Key
"signature" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8 (ByteString -> ByteString
B16.encode (SigDSIGN DSIGN -> ByteString
forall a. FixedSizeCodec a => a -> ByteString
rawEncodeFixedSized SigDSIGN DSIGN
sig))
      ]

instance Typeable kr => FromJSON (WitVKey kr) where
  parseJSON :: Value -> Parser (WitVKey kr)
parseJSON = String
-> (Object -> Parser (WitVKey kr)) -> Value -> Parser (WitVKey kr)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"WitVKey" ((Object -> Parser (WitVKey kr)) -> Value -> Parser (WitVKey kr))
-> (Object -> Parser (WitVKey kr)) -> Value -> Parser (WitVKey kr)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    !keyHex <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"key" :: Parser Text
    !sigHex <- o .: "signature" :: Parser Text
    !keyBytes <- either fail pure $ B16.decode (Text.encodeUtf8 keyHex)
    !sigBytes <- either fail pure $ B16.decode (Text.encodeUtf8 sigHex)
    !vk <- rawDecodeFixedSized keyBytes
    !sig <- rawDecodeFixedSized sigBytes
    pure $ WitVKey (VKey vk) (SignedDSIGN sig)

instance EncCBOR (WitVKey kr) where
  encCBOR :: WitVKey kr -> Encoding
encCBOR (WitVKey VKey kr
k SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
sig) =
    Word -> Encoding
encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> VKey kr -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR VKey kr
k
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody) -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
sig

instance Typeable kr => DecCBOR (WitVKey kr) where
  decCBOR :: forall s. Decoder s (WitVKey kr)
decCBOR =
    Text
-> (WitVKey kr -> Int)
-> Decoder s (WitVKey kr)
-> Decoder s (WitVKey kr)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"WitVKey" (Int -> WitVKey kr -> Int
forall a b. a -> b -> a
const Int
2) (Decoder s (WitVKey kr) -> Decoder s (WitVKey kr))
-> Decoder s (WitVKey kr) -> Decoder s (WitVKey kr)
forall a b. (a -> b) -> a -> b
$
      VKey kr
-> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody) -> WitVKey kr
forall (kr :: KeyRole).
VKey kr
-> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody) -> WitVKey kr
WitVKey (VKey kr
 -> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
 -> WitVKey kr)
-> Decoder s (VKey kr)
-> Decoder
     s
     (SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody) -> WitVKey kr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (VKey kr)
forall s. Decoder s (VKey kr)
forall a s. DecCBOR a => Decoder s a
decCBOR Decoder
  s
  (SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody) -> WitVKey kr)
-> Decoder s (SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody))
-> Decoder s (WitVKey kr)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody))
forall s.
Decoder s (SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody))
forall a s. DecCBOR a => Decoder s a
decCBOR
  {-# INLINE decCBOR #-}

pattern WitVKey ::
  VKey kr ->
  SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody) ->
  WitVKey kr
pattern $mWitVKey :: forall {r} {kr :: KeyRole}.
WitVKey kr
-> (VKey kr
    -> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody) -> r)
-> ((# #) -> r)
-> r
$bWitVKey :: forall (kr :: KeyRole).
VKey kr
-> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody) -> WitVKey kr
WitVKey k s <-
  WitVKeyInternal k s _
  where
    WitVKey VKey kr
k SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
s =
      let hash :: KeyHash Witness
hash = KeyHash kr -> KeyHash Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a Witness
asWitness (KeyHash kr -> KeyHash Witness) -> KeyHash kr -> KeyHash Witness
forall a b. (a -> b) -> a -> b
$ VKey kr -> KeyHash kr
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey VKey kr
k
       in VKey kr
-> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
-> KeyHash Witness
-> WitVKey kr
forall (kr :: KeyRole).
VKey kr
-> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
-> KeyHash Witness
-> WitVKey kr
WitVKeyInternal VKey kr
k SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
s KeyHash Witness
hash

{-# COMPLETE WitVKey #-}

-- | Access computed hash. Evaluated lazily
witVKeyHash :: WitVKey kr -> KeyHash Witness
witVKeyHash :: forall (kr :: KeyRole). WitVKey kr -> KeyHash Witness
witVKeyHash = WitVKey kr -> KeyHash Witness
forall (kr :: KeyRole). WitVKey kr -> KeyHash Witness
wvkKeyHash