{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}

module Cardano.Crypto.Signing.Signature (
  -- * Signature
  Signature (..),
  encCBORXSignature,
  decCBORXSignature,
  fullSignatureHexF,
  parseFullSignature,

  -- * Signing
  sign,
  signEncoded,
  signRaw,
  safeSign,
  safeSignRaw,

  -- * Verification
  verifySignature,
  verifySignatureDecoded,
  verifySignatureRaw,
)
where

import Cardano.Crypto.ProtocolMagic (ProtocolMagicId)
import Cardano.Crypto.Raw (Raw (..))
import Cardano.Crypto.Signing.Safe (
  PassPhrase (..),
  SafeSigner (..),
 )
import Cardano.Crypto.Signing.SigningKey (SigningKey (..))
import Cardano.Crypto.Signing.Tag (SignTag (..), signTag, signTagDecoded)
import Cardano.Crypto.Signing.VerificationKey (VerificationKey (..))
import qualified Cardano.Crypto.Wallet as CC
import Cardano.Ledger.Binary (
  Annotated (..),
  DecCBOR (..),
  Decoded (..),
  Decoder,
  EncCBOR (..),
  Encoding,
  FromCBOR (..),
  ToCBOR (..),
  byronProtVer,
  fromByronCBOR,
  serialize,
  serialize',
  toByronCBOR,
  toCborError,
 )
import Cardano.Prelude hiding (toCborError)
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.ByteArray (ScrubbedBytes)
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as BSL
import Data.Coerce (coerce)
import qualified Data.Text.Encoding as T
import Formatting (Format, bprint, formatToString, later, sformat, shown, stext)
import qualified Formatting.Buildable as B
import NoThunks.Class (InspectHeap (..), NoThunks (..))
import Text.JSON.Canonical (JSValue (..), toJSString)
import qualified Text.JSON.Canonical as TJC (FromJSON (..), ToJSON (..))

--------------------------------------------------------------------------------
-- Signature
--------------------------------------------------------------------------------

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

instance B.Buildable (Signature a) where
  build :: Signature a -> Builder
build Signature a
_ = Builder
"<signature>"

instance FromJSON (Signature w) where
  parseJSON :: Value -> Parser (Signature w)
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
. forall a. Text -> Either SignatureParseError (Signature a)
parseFullSignature

instance ToJSON (Signature w) where
  toJSON :: Signature w -> 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 a. Format r (Signature a -> r)
fullSignatureHexF

instance Monad m => TJC.ToJSON m (Signature w) where
  toJSON :: Signature w -> 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 a. Format r (Signature a -> r)
fullSignatureHexF

instance (Typeable x, MonadError SchemaError m) => TJC.FromJSON m (Signature x) where
  fromJSON :: JSValue -> m (Signature x)
fromJSON = forall a (m :: * -> *) e.
(Typeable a, ReportSchemaErrors m, Buildable e) =>
(Text -> Either e a) -> JSValue -> m a
parseJSString forall a. Text -> Either SignatureParseError (Signature a)
parseFullSignature

-- | Formatter for 'Signature' to show it in hex.
fullSignatureHexF :: Format r (Signature a -> r)
fullSignatureHexF :: forall r a. Format r (Signature a -> r)
fullSignatureHexF =
  forall a r. (a -> Builder) -> Format r (a -> r)
later forall a b. (a -> b) -> a -> b
$ \(Signature XSignature
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
. XSignature -> ByteString
CC.unXSignature forall a b. (a -> b) -> a -> b
$ XSignature
x

data SignatureParseError
  = SignatureParseBase16Error ByteString
  | SignatureParseXSignatureError Text
  deriving (SignatureParseError -> SignatureParseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SignatureParseError -> SignatureParseError -> Bool
$c/= :: SignatureParseError -> SignatureParseError -> Bool
== :: SignatureParseError -> SignatureParseError -> Bool
$c== :: SignatureParseError -> SignatureParseError -> Bool
Eq, Int -> SignatureParseError -> ShowS
[SignatureParseError] -> ShowS
SignatureParseError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SignatureParseError] -> ShowS
$cshowList :: [SignatureParseError] -> ShowS
show :: SignatureParseError -> String
$cshow :: SignatureParseError -> String
showsPrec :: Int -> SignatureParseError -> ShowS
$cshowsPrec :: Int -> SignatureParseError -> ShowS
Show)

instance B.Buildable SignatureParseError where
  build :: SignatureParseError -> Builder
build = \case
    SignatureParseBase16Error ByteString
bs ->
      forall a. Format Builder a -> a
bprint
        (Format (ByteString -> Builder) (ByteString -> Builder)
"Failed to parse base 16 while parsing Signature.\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 a r. Show a => Format r (a -> r)
shown)
        ByteString
bs
    SignatureParseXSignatureError Text
err ->
      forall a. Format Builder a -> a
bprint
        ( Format (Text -> Builder) (Text -> Builder)
"Failed to construct XSignature while parsing Signature.\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 'Signature' from base16 encoded string.
parseFullSignature :: Text -> Either SignatureParseError (Signature a)
parseFullSignature :: forall a. Text -> Either SignatureParseError (Signature a)
parseFullSignature Text
s = do
  let bs :: ByteString
bs = Text -> ByteString
T.encodeUtf8 Text
s
  ByteString
b <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b. a -> b -> a
const (ByteString -> SignatureParseError
SignatureParseBase16Error ByteString
bs)) forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
B16.decode ByteString
bs
  forall a. XSignature -> Signature a
Signature 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 -> SignatureParseError
SignatureParseXSignatureError forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. ConvertText a b => a -> b
toS) (ByteString -> Either String XSignature
CC.xsignature ByteString
b)

encCBORXSignature :: CC.XSignature -> Encoding
encCBORXSignature :: XSignature -> Encoding
encCBORXSignature XSignature
a = forall a. EncCBOR a => a -> Encoding
encCBOR forall a b. (a -> b) -> a -> b
$ XSignature -> ByteString
CC.unXSignature XSignature
a

decCBORXSignature :: Decoder s CC.XSignature
decCBORXSignature :: forall s. Decoder s XSignature
decCBORXSignature = 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 XSignature
CC.xsignature forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a s. DecCBOR a => Decoder s a
decCBOR

instance Typeable a => ToCBOR (Signature a) where
  toCBOR :: Signature a -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance Typeable a => FromCBOR (Signature a) where
  fromCBOR :: forall s. Decoder s (Signature a)
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance Typeable a => EncCBOR (Signature a) where
  encCBOR :: Signature a -> Encoding
encCBOR (Signature XSignature
a) = XSignature -> Encoding
encCBORXSignature XSignature
a
  encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (Signature a) -> Size
encodedSizeExpr forall t. EncCBOR t => Proxy t -> Size
_ Proxy (Signature a)
_ = Size
66

instance Typeable a => DecCBOR (Signature a) where
  decCBOR :: forall s. Decoder s (Signature a)
decCBOR = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. XSignature -> Signature a
Signature forall s. Decoder s XSignature
decCBORXSignature

--------------------------------------------------------------------------------
-- Signing
--------------------------------------------------------------------------------

-- | Encode something with 'EncCBOR' and sign it
sign ::
  EncCBOR a =>
  ProtocolMagicId ->
  -- | See docs for 'SignTag'
  SignTag ->
  SigningKey ->
  a ->
  Signature a
sign :: forall a.
EncCBOR a =>
ProtocolMagicId -> SignTag -> SigningKey -> a -> Signature a
sign ProtocolMagicId
pm SignTag
tag SigningKey
sk = forall a.
ProtocolMagicId -> SignTag -> SigningKey -> Encoding -> Signature a
signEncoded ProtocolMagicId
pm SignTag
tag SigningKey
sk forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. EncCBOR a => a -> Encoding
encCBOR

-- | Like 'sign' but without the 'EncCBOR' constraint
signEncoded ::
  ProtocolMagicId -> SignTag -> SigningKey -> Encoding -> Signature a
signEncoded :: forall a.
ProtocolMagicId -> SignTag -> SigningKey -> Encoding -> Signature a
signEncoded ProtocolMagicId
pm SignTag
tag SigningKey
sk =
  coerce :: forall a b. Coercible a b => a -> b
coerce forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ProtocolMagicId
-> Maybe SignTag -> SigningKey -> ByteString -> Signature Raw
signRaw ProtocolMagicId
pm (forall a. a -> Maybe a
Just SignTag
tag) SigningKey
sk forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
BSL.toStrict forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer

-- | Sign a 'Raw' bytestring
signRaw ::
  ProtocolMagicId ->
  -- | See docs for 'SignTag'. Unlike in 'sign', we allow no tag to be provided
  --   just in case you need to sign /exactly/ the bytestring you provided.
  Maybe SignTag ->
  SigningKey ->
  ByteString ->
  Signature Raw
signRaw :: ProtocolMagicId
-> Maybe SignTag -> SigningKey -> ByteString -> Signature Raw
signRaw ProtocolMagicId
pm Maybe SignTag
mTag (SigningKey XPrv
sk) ByteString
x =
  forall a. XSignature -> Signature a
Signature
    (forall passPhrase msg.
(ByteArrayAccess passPhrase, ByteArrayAccess msg) =>
passPhrase -> XPrv -> msg -> XSignature
CC.sign (forall a. Monoid a => a
mempty :: ScrubbedBytes) XPrv
sk (ByteString
tag forall a. Semigroup a => a -> a -> a
<> ByteString
x))
  where
    tag :: ByteString
tag = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (ProtocolMagicId -> SignTag -> ByteString
signTag ProtocolMagicId
pm) Maybe SignTag
mTag

safeSign ::
  EncCBOR a => ProtocolMagicId -> SignTag -> SafeSigner -> a -> Signature a
safeSign :: forall a.
EncCBOR a =>
ProtocolMagicId -> SignTag -> SafeSigner -> a -> Signature a
safeSign ProtocolMagicId
pm SignTag
t SafeSigner
ss = coerce :: forall a b. Coercible a b => a -> b
coerce forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ProtocolMagicId
-> Maybe SignTag -> SafeSigner -> ByteString -> Signature Raw
safeSignRaw ProtocolMagicId
pm (forall a. a -> Maybe a
Just SignTag
t) SafeSigner
ss forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
byronProtVer

safeSignRaw ::
  ProtocolMagicId ->
  Maybe SignTag ->
  SafeSigner ->
  ByteString ->
  Signature Raw
safeSignRaw :: ProtocolMagicId
-> Maybe SignTag -> SafeSigner -> ByteString -> Signature Raw
safeSignRaw ProtocolMagicId
pm Maybe SignTag
mbTag (SafeSigner (SigningKey XPrv
sk) (PassPhrase ScrubbedBytes
pp)) ByteString
x =
  forall a. XSignature -> Signature a
Signature (forall passPhrase msg.
(ByteArrayAccess passPhrase, ByteArrayAccess msg) =>
passPhrase -> XPrv -> msg -> XSignature
CC.sign ScrubbedBytes
pp XPrv
sk (ByteString
tag forall a. Semigroup a => a -> a -> a
<> ByteString
x))
  where
    tag :: ByteString
tag = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (ProtocolMagicId -> SignTag -> ByteString
signTag ProtocolMagicId
pm) Maybe SignTag
mbTag

--------------------------------------------------------------------------------
-- Verification
--------------------------------------------------------------------------------

-- | Verify a signature
verifySignature ::
  (a -> Encoding) ->
  ProtocolMagicId ->
  SignTag ->
  VerificationKey ->
  a ->
  Signature a ->
  Bool
verifySignature :: forall a.
(a -> Encoding)
-> ProtocolMagicId
-> SignTag
-> VerificationKey
-> a
-> Signature a
-> Bool
verifySignature a -> Encoding
toEnc ProtocolMagicId
pm SignTag
tag VerificationKey
vk a
x Signature a
sig =
  VerificationKey -> ByteString -> Signature Raw -> Bool
verifySignatureRaw
    VerificationKey
vk
    (ProtocolMagicId -> SignTag -> ByteString
signTag ProtocolMagicId
pm SignTag
tag forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BSL.toStrict (forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer forall a b. (a -> b) -> a -> b
$ a -> Encoding
toEnc a
x))
    (coerce :: forall a b. Coercible a b => a -> b
coerce Signature a
sig)

-- | Verify a signature
verifySignatureDecoded ::
  Decoded t =>
  Annotated ProtocolMagicId ByteString ->
  SignTag ->
  VerificationKey ->
  t ->
  Signature (BaseType t) ->
  Bool
verifySignatureDecoded :: forall t.
Decoded t =>
Annotated ProtocolMagicId ByteString
-> SignTag
-> VerificationKey
-> t
-> Signature (BaseType t)
-> Bool
verifySignatureDecoded Annotated ProtocolMagicId ByteString
pm SignTag
tag VerificationKey
vk t
x Signature (BaseType t)
sig =
  VerificationKey -> ByteString -> Signature Raw -> Bool
verifySignatureRaw VerificationKey
vk (Annotated ProtocolMagicId ByteString -> SignTag -> ByteString
signTagDecoded Annotated ProtocolMagicId ByteString
pm SignTag
tag forall a. Semigroup a => a -> a -> a
<> forall t. Decoded t => t -> ByteString
recoverBytes t
x) (coerce :: forall a b. Coercible a b => a -> b
coerce Signature (BaseType t)
sig)

-- | Verify 'Raw' signature
verifySignatureRaw ::
  VerificationKey ->
  ByteString ->
  Signature Raw ->
  Bool
verifySignatureRaw :: VerificationKey -> ByteString -> Signature Raw -> Bool
verifySignatureRaw (VerificationKey XPub
k) ByteString
x (Signature XSignature
sig) = forall msg.
ByteArrayAccess msg =>
XPub -> msg -> XSignature -> Bool
CC.verify XPub
k ByteString
x XSignature
sig