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

module Cardano.Crypto.Signing.Redeem.VerificationKey (
  RedeemVerificationKey (..),
  redeemVKB64F,
  redeemVKB64UrlF,
  redeemVKB64ShortF,
  fromAvvmVK,
  fromVerificationKeyToByteString,
  redeemVKBuild,
)
where

import Cardano.Crypto.Orphans ()
import Cardano.Ledger.Binary (DecCBOR, EncCBOR, FromCBOR, ToCBOR)
import Cardano.Prelude
import Crypto.Error (CryptoFailable (..))
import qualified Crypto.PubKey.Ed25519 as Ed25519
import Data.Aeson (
  FromJSONKey (..),
  FromJSONKeyFunction (..),
  ToJSONKey (..),
  ToJSONKeyFunction (..),
 )
import qualified Data.Aeson.Encoding.Internal as A (key)
import qualified Data.Aeson.Key as A
import Data.Aeson.TH (defaultOptions, deriveJSON)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Base64.URL as B64URL
import qualified Data.ByteString.Char8 as Char8
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Formatting (
  Format,
  bprint,
  build,
  fitLeft,
  formatToString,
  later,
  sformat,
  stext,
  (%.),
 )
import qualified Formatting.Buildable as B
import NoThunks.Class (InspectHeap (..), NoThunks (..))
import Text.JSON.Canonical (
  FromObjectKey (..),
  JSValue (..),
  ToObjectKey (..),
  toJSString,
 )

-- | Wrapper around 'Ed25519.PublicKey'.
type RedeemVerificationKey :: Type
newtype RedeemVerificationKey
  = RedeemVerificationKey Ed25519.PublicKey
  deriving (RedeemVerificationKey -> RedeemVerificationKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RedeemVerificationKey -> RedeemVerificationKey -> Bool
$c/= :: RedeemVerificationKey -> RedeemVerificationKey -> Bool
== :: RedeemVerificationKey -> RedeemVerificationKey -> Bool
$c== :: RedeemVerificationKey -> RedeemVerificationKey -> Bool
Eq, Int -> RedeemVerificationKey -> ShowS
[RedeemVerificationKey] -> ShowS
RedeemVerificationKey -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RedeemVerificationKey] -> ShowS
$cshowList :: [RedeemVerificationKey] -> ShowS
show :: RedeemVerificationKey -> String
$cshow :: RedeemVerificationKey -> String
showsPrec :: Int -> RedeemVerificationKey -> ShowS
$cshowsPrec :: Int -> RedeemVerificationKey -> ShowS
Show, forall x. Rep RedeemVerificationKey x -> RedeemVerificationKey
forall x. RedeemVerificationKey -> Rep RedeemVerificationKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RedeemVerificationKey x -> RedeemVerificationKey
$cfrom :: forall x. RedeemVerificationKey -> Rep RedeemVerificationKey x
Generic, RedeemVerificationKey -> ()
forall a. (a -> ()) -> NFData a
rnf :: RedeemVerificationKey -> ()
$crnf :: RedeemVerificationKey -> ()
NFData, Typeable RedeemVerificationKey
Proxy RedeemVerificationKey -> Text
forall s. Decoder s RedeemVerificationKey
forall a.
Typeable a
-> (forall s. Decoder s a)
-> (forall s. Proxy a -> Decoder s ())
-> (Proxy a -> Text)
-> DecCBOR a
forall s. Proxy RedeemVerificationKey -> Decoder s ()
label :: Proxy RedeemVerificationKey -> Text
$clabel :: Proxy RedeemVerificationKey -> Text
dropCBOR :: forall s. Proxy RedeemVerificationKey -> Decoder s ()
$cdropCBOR :: forall s. Proxy RedeemVerificationKey -> Decoder s ()
decCBOR :: forall s. Decoder s RedeemVerificationKey
$cdecCBOR :: forall s. Decoder s RedeemVerificationKey
DecCBOR, Typeable RedeemVerificationKey
RedeemVerificationKey -> Encoding
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [RedeemVerificationKey] -> Size
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy RedeemVerificationKey -> 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 [RedeemVerificationKey] -> Size
$cencodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [RedeemVerificationKey] -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy RedeemVerificationKey -> Size
$cencodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy RedeemVerificationKey -> Size
encCBOR :: RedeemVerificationKey -> Encoding
$cencCBOR :: RedeemVerificationKey -> Encoding
EncCBOR, Typeable RedeemVerificationKey
Proxy RedeemVerificationKey -> Text
forall s. Decoder s RedeemVerificationKey
forall a.
Typeable a
-> (forall s. Decoder s a) -> (Proxy a -> Text) -> FromCBOR a
label :: Proxy RedeemVerificationKey -> Text
$clabel :: Proxy RedeemVerificationKey -> Text
fromCBOR :: forall s. Decoder s RedeemVerificationKey
$cfromCBOR :: forall s. Decoder s RedeemVerificationKey
FromCBOR, Typeable RedeemVerificationKey
RedeemVerificationKey -> Encoding
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [RedeemVerificationKey] -> Size
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy RedeemVerificationKey -> 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
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [RedeemVerificationKey] -> Size
$cencodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [RedeemVerificationKey] -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy RedeemVerificationKey -> Size
$cencodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy RedeemVerificationKey -> Size
toCBOR :: RedeemVerificationKey -> Encoding
$ctoCBOR :: RedeemVerificationKey -> Encoding
ToCBOR)
  deriving (Context -> RedeemVerificationKey -> IO (Maybe ThunkInfo)
Proxy RedeemVerificationKey -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy RedeemVerificationKey -> String
$cshowTypeOf :: Proxy RedeemVerificationKey -> String
wNoThunks :: Context -> RedeemVerificationKey -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> RedeemVerificationKey -> IO (Maybe ThunkInfo)
noThunks :: Context -> RedeemVerificationKey -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> RedeemVerificationKey -> IO (Maybe ThunkInfo)
NoThunks) via InspectHeap RedeemVerificationKey

-- Note that normally we would not provide any Ord instances.
-- The crypto libraries encourage using key /hashes/ not keys for
-- things like sets, map etc. However due to a historical mistake the
-- AVVM balances use whole keys, not key hashes. So we compromise here
-- and provide Ord instances so we can use RedeemVerificationKey
-- as the key type in a Data.Map.

instance Ord RedeemVerificationKey where
  RedeemVerificationKey PublicKey
a compare :: RedeemVerificationKey -> RedeemVerificationKey -> Ordering
`compare` RedeemVerificationKey PublicKey
b =
    forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert PublicKey
a forall a. Ord a => a -> a -> Ordering
`compare` (forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert PublicKey
b :: ByteString)

fromVerificationKeyToByteString :: Ed25519.PublicKey -> BS.ByteString
fromVerificationKeyToByteString :: PublicKey -> ByteString
fromVerificationKeyToByteString = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert

-- | Base64url Format for 'RedeemVerificationKey'.
redeemVKB64UrlF :: Format r (RedeemVerificationKey -> r)
redeemVKB64UrlF :: forall r. Format r (RedeemVerificationKey -> r)
redeemVKB64UrlF = forall a r. (a -> Builder) -> Format r (a -> r)
later forall a b. (a -> b) -> a -> b
$ \(RedeemVerificationKey PublicKey
vk) ->
  forall p. Buildable p => p -> Builder
B.build forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> String
Char8.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
B64URL.encode forall a b. (a -> b) -> a -> b
$ PublicKey -> ByteString
fromVerificationKeyToByteString PublicKey
vk

instance Monad m => ToObjectKey m RedeemVerificationKey where
  toObjectKey :: RedeemVerificationKey -> m JSString
toObjectKey = 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
. 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 (RedeemVerificationKey -> r)
redeemVKB64UrlF

type AvvmVKError :: Type
data AvvmVKError
  = ApeAddressFormat Text
  | ApeAddressLength Int
  deriving (Int -> AvvmVKError -> ShowS
[AvvmVKError] -> ShowS
AvvmVKError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AvvmVKError] -> ShowS
$cshowList :: [AvvmVKError] -> ShowS
show :: AvvmVKError -> String
$cshow :: AvvmVKError -> String
showsPrec :: Int -> AvvmVKError -> ShowS
$cshowsPrec :: Int -> AvvmVKError -> ShowS
Show)

-- | Creates a verification key from 32 byte bytestring, fails with 'error' otherwise
redeemVKBuild :: ByteString -> RedeemVerificationKey
redeemVKBuild :: ByteString -> RedeemVerificationKey
redeemVKBuild ByteString
bs
  | ByteString -> Int
BS.length ByteString
bs forall a. Eq a => a -> a -> Bool
/= Int
32 =
      forall a. HasCallStack => Text -> a
panic
        forall a b. (a -> b) -> a -> b
$ Text
"consRedeemVK: failed to form vk, wrong bs length: "
        forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, ConvertText String b) => a -> b
show (ByteString -> Int
BS.length ByteString
bs)
        forall a. Semigroup a => a -> a -> a
<> Text
", when should be 32"
  | Bool
otherwise =
      case forall ba. ByteArrayAccess ba => ba -> CryptoFailable PublicKey
Ed25519.publicKey (forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert ByteString
bs :: BA.Bytes) of
        CryptoPassed PublicKey
r -> PublicKey -> RedeemVerificationKey
RedeemVerificationKey PublicKey
r
        CryptoFailed CryptoError
e ->
          forall a. HasCallStack => Text -> a
panic
            forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> a -> a
mappend
              Text
"Cardano.Crypto.Signing.Types.Redeem.hs consRedeemVK failed because "
              (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a b. (Show a, ConvertText String b) => a -> b
show CryptoError
e)

-- | Read the text into a redeeming verification key. The key should be in
--   AVVM format which is base64(url). This function must be inverse of
--   redeemVKB64UrlF formatter.
fromAvvmVK :: Text -> Either AvvmVKError RedeemVerificationKey
fromAvvmVK :: Text -> Either AvvmVKError RedeemVerificationKey
fromAvvmVK Text
addrText = do
  let base64rify :: Text -> Text
base64rify = Text -> Text -> Text -> Text
T.replace Text
"-" Text
"+" forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Text -> Text -> Text
T.replace Text
"_" Text
"/"
  let parsedM :: Either String ByteString
parsedM = ByteString -> Either String ByteString
B64.decode forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
T.encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text -> Text
base64rify Text
addrText
  ByteString
addrParsed <- case Either String ByteString
parsedM of
    Left String
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> AvvmVKError
ApeAddressFormat Text
addrText
    Right ByteString
a -> forall a b. b -> Either a b
Right ByteString
a
  let len :: Int
len = ByteString -> Int
BS.length ByteString
addrParsed
  (Int
len forall a. Eq a => a -> a -> Bool
== Int
32) forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` Int -> AvvmVKError
ApeAddressLength Int
len
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> RedeemVerificationKey
redeemVKBuild ByteString
addrParsed

instance B.Buildable AvvmVKError where
  build :: AvvmVKError -> Builder
build = \case
    ApeAddressFormat Text
addrText ->
      forall a. Format Builder a -> a
bprint (Format (Text -> Builder) (Text -> Builder)
"Address " 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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder Builder
" is not base64(url) format") Text
addrText
    ApeAddressLength Int
len ->
      forall a. Format Builder a -> a
bprint
        (Format (Int -> Builder) (Int -> Builder)
"Address length is " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a r. Buildable a => Format r (a -> r)
build forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder Builder
", expected 32, can't be redeeming vk")
        Int
len

instance MonadError SchemaError m => FromObjectKey m RedeemVerificationKey where
  fromObjectKey :: JSString -> m (Maybe RedeemVerificationKey)
fromObjectKey =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a (m :: * -> *) e.
(Typeable a, ReportSchemaErrors m, Buildable e) =>
(Text -> Either e a) -> JSValue -> m a
parseJSString (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. Format Text a -> a
sformat forall a r. Buildable a => Format r (a -> r)
build) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Either AvvmVKError RedeemVerificationKey
fromAvvmVK) 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

deriveJSON defaultOptions ''RedeemVerificationKey

instance ToJSONKey RedeemVerificationKey where
  toJSONKey :: ToJSONKeyFunction RedeemVerificationKey
toJSONKey = forall a. (a -> Key) -> (a -> Encoding' Key) -> ToJSONKeyFunction a
ToJSONKeyText RedeemVerificationKey -> Key
render (forall a. Key -> Encoding' a
A.key forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RedeemVerificationKey -> Key
render)
    where
      render :: RedeemVerificationKey -> Key
render = Text -> Key
A.fromText 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 (RedeemVerificationKey -> r)
redeemVKB64UrlF

instance FromJSONKey RedeemVerificationKey where
  fromJSONKey :: FromJSONKeyFunction RedeemVerificationKey
fromJSONKey =
    forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser forall a b. (a -> b) -> a -> 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
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. Format Text a -> a
sformat forall a r. Buildable a => Format r (a -> r)
build) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Either AvvmVKError RedeemVerificationKey
fromAvvmVK
  fromJSONKeyList :: FromJSONKeyFunction [RedeemVerificationKey]
fromJSONKeyList =
    forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser
      forall a b. (a -> b) -> a -> 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
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a. Format Text a -> a
sformat forall a r. Buildable a => Format r (a -> r)
build) 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
. Text -> Either AvvmVKError RedeemVerificationKey
fromAvvmVK

instance B.Buildable RedeemVerificationKey where
  build :: RedeemVerificationKey -> Builder
build = forall a. Format Builder a -> a
bprint (Format
  (RedeemVerificationKey -> Builder)
  (RedeemVerificationKey -> Builder)
"redeem_vk:" 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 (RedeemVerificationKey -> r)
redeemVKB64F)

redeemVKB64F :: Format r (RedeemVerificationKey -> r)
redeemVKB64F :: forall r. Format r (RedeemVerificationKey -> r)
redeemVKB64F = forall a r. (a -> Builder) -> Format r (a -> r)
later forall a b. (a -> b) -> a -> b
$ \(RedeemVerificationKey PublicKey
vk) ->
  forall p. Buildable p => p -> Builder
B.build forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> String
Char8.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 a b. (a -> b) -> a -> b
$ PublicKey -> ByteString
fromVerificationKeyToByteString PublicKey
vk

redeemVKB64ShortF :: Format r (RedeemVerificationKey -> r)
redeemVKB64ShortF :: forall r. Format r (RedeemVerificationKey -> r)
redeemVKB64ShortF = 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 (RedeemVerificationKey -> r)
redeemVKB64F