{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Crypto.Signing.VerificationKey (
  VerificationKey (..),
  formatFullVerificationKey,
  fullVerificationKeyF,
  fullVerificationKeyHexF,
  shortVerificationKeyHexF,
  parseFullVerificationKey,
)
where

import qualified Cardano.Crypto.Wallet as CC
import Cardano.Ledger.Binary (
  DecCBOR (..),
  Decoder,
  EncCBOR (..),
  Encoding,
  FromCBOR (..),
  ToCBOR (..),
  decodeBytesCanonical,
  fromByronCBOR,
  toByronCBOR,
  toCborError,
 )
import Cardano.Prelude hiding (toCborError)
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as Builder
import Formatting (
  Format,
  bprint,
  fitLeft,
  formatToString,
  later,
  sformat,
  stext,
  (%.),
 )
import Formatting.Buildable (Buildable (..))
import NoThunks.Class (InspectHeap (..), NoThunks (..))
import Text.JSON.Canonical (JSValue (..), toJSString)
import qualified Text.JSON.Canonical as TJC (FromJSON (..), ToJSON (..))

-- | Wrapper around 'CC.XPub'.
type VerificationKey :: Type
newtype VerificationKey = VerificationKey
  { VerificationKey -> XPub
unVerificationKey :: CC.XPub
  }
  deriving stock (VerificationKey -> VerificationKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VerificationKey -> VerificationKey -> Bool
$c/= :: VerificationKey -> VerificationKey -> Bool
== :: VerificationKey -> VerificationKey -> Bool
$c== :: VerificationKey -> VerificationKey -> Bool
Eq, Eq VerificationKey
VerificationKey -> VerificationKey -> Bool
VerificationKey -> VerificationKey -> Ordering
VerificationKey -> VerificationKey -> VerificationKey
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 :: VerificationKey -> VerificationKey -> VerificationKey
$cmin :: VerificationKey -> VerificationKey -> VerificationKey
max :: VerificationKey -> VerificationKey -> VerificationKey
$cmax :: VerificationKey -> VerificationKey -> VerificationKey
>= :: VerificationKey -> VerificationKey -> Bool
$c>= :: VerificationKey -> VerificationKey -> Bool
> :: VerificationKey -> VerificationKey -> Bool
$c> :: VerificationKey -> VerificationKey -> Bool
<= :: VerificationKey -> VerificationKey -> Bool
$c<= :: VerificationKey -> VerificationKey -> Bool
< :: VerificationKey -> VerificationKey -> Bool
$c< :: VerificationKey -> VerificationKey -> Bool
compare :: VerificationKey -> VerificationKey -> Ordering
$ccompare :: VerificationKey -> VerificationKey -> Ordering
Ord, Int -> VerificationKey -> ShowS
[VerificationKey] -> ShowS
VerificationKey -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VerificationKey] -> ShowS
$cshowList :: [VerificationKey] -> ShowS
show :: VerificationKey -> String
$cshow :: VerificationKey -> String
showsPrec :: Int -> VerificationKey -> ShowS
$cshowsPrec :: Int -> VerificationKey -> ShowS
Show, forall x. Rep VerificationKey x -> VerificationKey
forall x. VerificationKey -> Rep VerificationKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep VerificationKey x -> VerificationKey
$cfrom :: forall x. VerificationKey -> Rep VerificationKey x
Generic)
  deriving newtype (VerificationKey -> ()
forall a. (a -> ()) -> NFData a
rnf :: VerificationKey -> ()
$crnf :: VerificationKey -> ()
NFData)
  deriving (Context -> VerificationKey -> IO (Maybe ThunkInfo)
Proxy VerificationKey -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy VerificationKey -> String
$cshowTypeOf :: Proxy VerificationKey -> String
wNoThunks :: Context -> VerificationKey -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> VerificationKey -> IO (Maybe ThunkInfo)
noThunks :: Context -> VerificationKey -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> VerificationKey -> IO (Maybe ThunkInfo)
NoThunks) via InspectHeap CC.XPub

instance ToJSON VerificationKey where
  toJSON :: VerificationKey -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Format Text a -> a
sformat forall r. Format r (VerificationKey -> r)
fullVerificationKeyF

instance FromJSON VerificationKey where
  parseJSON :: Value -> Parser VerificationKey
parseJSON Value
v = forall a. FromJSON a => Value -> Parser a
parseJSON Value
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e a. Buildable e => Either e a -> Parser a
toAesonError forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Either VerificationKeyParseError VerificationKey
parseFullVerificationKey

instance Monad m => TJC.ToJSON m VerificationKey where
  toJSON :: VerificationKey -> m JSValue
toJSON = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. JSString -> JSValue
JSString forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> JSString
toJSString forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Format String a -> a
formatToString forall r. Format r (VerificationKey -> r)
fullVerificationKeyF

instance MonadError SchemaError m => TJC.FromJSON m VerificationKey where
  fromJSON :: JSValue -> m VerificationKey
fromJSON = forall a (m :: * -> *) e.
(Typeable a, ReportSchemaErrors m, Buildable e) =>
(Text -> Either e a) -> JSValue -> m a
parseJSString Text -> Either VerificationKeyParseError VerificationKey
parseFullVerificationKey

instance ToCBOR VerificationKey where
  toCBOR :: VerificationKey -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR VerificationKey where
  fromCBOR :: forall s. Decoder s VerificationKey
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance EncCBOR VerificationKey where
  encCBOR :: VerificationKey -> Encoding
encCBOR (VerificationKey XPub
a) = XPub -> Encoding
encCBORXPub XPub
a
  encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy VerificationKey -> Size
encodedSizeExpr forall t. EncCBOR t => Proxy t -> Size
_ Proxy VerificationKey
_ = Size
66

instance DecCBOR VerificationKey where
  decCBOR :: forall s. Decoder s VerificationKey
decCBOR = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap XPub -> VerificationKey
VerificationKey forall s. Decoder s XPub
decCBORXPub

encCBORXPub :: CC.XPub -> Encoding
encCBORXPub :: XPub -> Encoding
encCBORXPub XPub
a = forall a. EncCBOR a => a -> Encoding
encCBOR forall a b. (a -> b) -> a -> b
$ XPub -> ByteString
CC.unXPub XPub
a

-- | We enforce canonical CBOR encodings for `VerificationKey`s, because we serialize
--   them before hashing to get `KeyHash`es.
decCBORXPub :: Decoder s CC.XPub
decCBORXPub :: forall s. Decoder s XPub
decCBORXPub = forall (m :: * -> *) e a.
(MonadFail m, Buildable e) =>
Either e a -> m a
toCborError forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Either String XPub
CC.xpub forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. Decoder s ByteString
decodeBytesCanonical

instance Buildable VerificationKey where
  build :: VerificationKey -> Builder
build = forall a. Format Builder a -> a
bprint (Format (VerificationKey -> Builder) (VerificationKey -> Builder)
"pub:" forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (VerificationKey -> r)
shortVerificationKeyHexF)

-- | 'Builder' for 'VerificationKey' to show it in base64 encoded form.
formatFullVerificationKey :: VerificationKey -> Builder
formatFullVerificationKey :: VerificationKey -> Builder
formatFullVerificationKey (VerificationKey XPub
vk) =
  String -> Builder
Builder.fromString forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> String
BS.unpack forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
B64.encode forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. XPub -> ByteString
CC.unXPub forall a b. (a -> b) -> a -> b
$ XPub
vk

-- | Formatter for 'VerificationKey' to show it in base64.
fullVerificationKeyF :: Format r (VerificationKey -> r)
fullVerificationKeyF :: forall r. Format r (VerificationKey -> r)
fullVerificationKeyF = forall a r. (a -> Builder) -> Format r (a -> r)
later VerificationKey -> Builder
formatFullVerificationKey

-- | Formatter for 'VerificationKey' to show it in hex.
fullVerificationKeyHexF :: Format r (VerificationKey -> r)
fullVerificationKeyHexF :: forall r. Format r (VerificationKey -> r)
fullVerificationKeyHexF = forall a r. (a -> Builder) -> Format r (a -> r)
later forall a b. (a -> b) -> a -> b
$ \(VerificationKey XPub
x) -> ByteString -> Builder
base16Builder forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. XPub -> ByteString
CC.unXPub forall a b. (a -> b) -> a -> b
$ XPub
x

-- | Formatter for 'VerificationKey' to show it in hex, but only first 8 chars.
shortVerificationKeyHexF :: Format r (VerificationKey -> r)
shortVerificationKeyHexF :: forall r. Format r (VerificationKey -> r)
shortVerificationKeyHexF = forall a r. Buildable a => Int -> Format r (a -> r)
fitLeft Int
8 forall r r' a.
Format r (Builder -> r') -> Format r' a -> Format r a
%. forall r. Format r (VerificationKey -> r)
fullVerificationKeyHexF

type VerificationKeyParseError :: Type
data VerificationKeyParseError
  = VerificationKeyParseBase64Error Text
  | VerificationKeyParseXPubError Text
  deriving (VerificationKeyParseError -> VerificationKeyParseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VerificationKeyParseError -> VerificationKeyParseError -> Bool
$c/= :: VerificationKeyParseError -> VerificationKeyParseError -> Bool
== :: VerificationKeyParseError -> VerificationKeyParseError -> Bool
$c== :: VerificationKeyParseError -> VerificationKeyParseError -> Bool
Eq, Int -> VerificationKeyParseError -> ShowS
[VerificationKeyParseError] -> ShowS
VerificationKeyParseError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VerificationKeyParseError] -> ShowS
$cshowList :: [VerificationKeyParseError] -> ShowS
show :: VerificationKeyParseError -> String
$cshow :: VerificationKeyParseError -> String
showsPrec :: Int -> VerificationKeyParseError -> ShowS
$cshowsPrec :: Int -> VerificationKeyParseError -> ShowS
Show)

instance Buildable VerificationKeyParseError where
  build :: VerificationKeyParseError -> Builder
build = \case
    VerificationKeyParseBase64Error Text
err ->
      forall a. Format Builder a -> a
bprint
        (Format (Text -> Builder) (Text -> Builder)
"Failed to decode base 64 while parsing VerificationKey.\n Error: " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (Text -> r)
stext)
        Text
err
    VerificationKeyParseXPubError Text
err ->
      forall a. Format Builder a -> a
bprint
        (Format (Text -> Builder) (Text -> Builder)
"Failed to construct XPub while parsing VerificationKey.\n Error: " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (Text -> r)
stext)
        Text
err

-- | Parse 'VerificationKey' from base64 encoded string
parseFullVerificationKey :: Text -> Either VerificationKeyParseError VerificationKey
parseFullVerificationKey :: Text -> Either VerificationKeyParseError VerificationKey
parseFullVerificationKey Text
s = do
  ByteString
b <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> VerificationKeyParseError
VerificationKeyParseBase64Error forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
Text.pack) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Either String ByteString
B64.decode forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 Text
s
  XPub -> VerificationKey
VerificationKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> VerificationKeyParseError
VerificationKeyParseXPubError forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
Text.pack) (ByteString -> Either String XPub
CC.xpub ByteString
b)