{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.CLI.Byron.Delegation
  ( ByronDelegationError (..)
  , checkByronGenesisDelegation
  , issueByronGenesisDelegation
  , renderByronDelegationError
  , serialiseDelegationCert
  , serialiseByronWitness
  )
where

import           Cardano.Api.Byron (ACertificate (delegateVK))
import           Cardano.Api.Byron hiding (delegateVK)
import qualified Cardano.Api.Ledger as L

import           Cardano.CLI.Byron.Key (ByronKeyFailure, renderByronKeyFailure)
import           Cardano.CLI.Types.Common (CertificateFile (..))
import           Cardano.Crypto (ProtocolMagicId)
import qualified Cardano.Crypto as Crypto
import           Cardano.Prelude (canonicalDecodePretty, canonicalEncodePretty)

import           Prelude hiding ((.))

import           Control.Category
import           Control.Monad (unless)
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
import           Data.Text (Text)
import           Formatting (Format, sformat)

data ByronDelegationError
  = CertificateValidationErrors !FilePath ![Text]
  | DlgCertificateDeserialisationFailed !FilePath !Text
  | ByronDelegationKeyError !ByronKeyFailure
  deriving Int -> ByronDelegationError -> ShowS
[ByronDelegationError] -> ShowS
ByronDelegationError -> String
(Int -> ByronDelegationError -> ShowS)
-> (ByronDelegationError -> String)
-> ([ByronDelegationError] -> ShowS)
-> Show ByronDelegationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ByronDelegationError -> ShowS
showsPrec :: Int -> ByronDelegationError -> ShowS
$cshow :: ByronDelegationError -> String
show :: ByronDelegationError -> String
$cshowList :: [ByronDelegationError] -> ShowS
showList :: [ByronDelegationError] -> ShowS
Show

renderByronDelegationError :: ByronDelegationError -> Doc ann
renderByronDelegationError :: forall ann. ByronDelegationError -> Doc ann
renderByronDelegationError = \case
  CertificateValidationErrors String
certFp [Text]
errs ->
    Doc ann
"Certificate validation error(s) at: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow String
certFp Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" Errors: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Text] -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow [Text]
errs
  DlgCertificateDeserialisationFailed String
certFp Text
deSererr ->
    Doc ann
"Certificate deserialisation error at: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow String
certFp Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" Error: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow Text
deSererr
  ByronDelegationKeyError ByronKeyFailure
kerr ->
    ByronKeyFailure -> Doc ann
forall ann. ByronKeyFailure -> Doc ann
renderByronKeyFailure ByronKeyFailure
kerr

-- TODO:  we need to support password-protected secrets.

-- | Issue a certificate for genesis delegation to a delegate key, signed by the
--   issuer key, for a given protocol magic and coming into effect at given epoch.
issueByronGenesisDelegation
  :: ProtocolMagicId
  -> EpochNumber
  -> Crypto.SigningKey
  -> Crypto.VerificationKey
  -> Certificate
issueByronGenesisDelegation :: ProtocolMagicId
-> EpochNumber -> SigningKey -> VerificationKey -> Certificate
issueByronGenesisDelegation ProtocolMagicId
magic EpochNumber
epoch SigningKey
issuerSK VerificationKey
delegateVK' =
  ProtocolMagicId
-> VerificationKey -> EpochNumber -> SafeSigner -> Certificate
signCertificate ProtocolMagicId
magic VerificationKey
delegateVK' EpochNumber
epoch (SafeSigner -> Certificate) -> SafeSigner -> Certificate
forall a b. (a -> b) -> a -> b
$
    SigningKey -> SafeSigner
Crypto.noPassSafeSigner SigningKey
issuerSK

-- | Verify that a certificate signifies genesis delegation by assumed genesis key
--   to a delegate key, for a given protocol magic.
--   If certificate fails validation, throw an error.
checkByronGenesisDelegation
  :: CertificateFile
  -> ProtocolMagicId
  -> Crypto.VerificationKey
  -> Crypto.VerificationKey
  -> ExceptT ByronDelegationError IO ()
checkByronGenesisDelegation :: CertificateFile
-> ProtocolMagicId
-> VerificationKey
-> VerificationKey
-> ExceptT ByronDelegationError IO ()
checkByronGenesisDelegation (CertificateFile String
certF) ProtocolMagicId
magic VerificationKey
issuer VerificationKey
delegate = do
  Either Text Certificate
ecert <- IO (Either Text Certificate)
-> ExceptT ByronDelegationError IO (Either Text Certificate)
forall a. IO a -> ExceptT ByronDelegationError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Certificate)
 -> ExceptT ByronDelegationError IO (Either Text Certificate))
-> IO (Either Text Certificate)
-> ExceptT ByronDelegationError IO (Either Text Certificate)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text Certificate
forall a.
FromJSON (Either SchemaError) a =>
ByteString -> Either Text a
canonicalDecodePretty (ByteString -> Either Text Certificate)
-> IO ByteString -> IO (Either Text Certificate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
LB.readFile String
certF
  case Either Text Certificate
ecert of
    Left Text
e -> ByronDelegationError -> ExceptT ByronDelegationError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ByronDelegationError -> ExceptT ByronDelegationError IO ())
-> ByronDelegationError -> ExceptT ByronDelegationError IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> ByronDelegationError
DlgCertificateDeserialisationFailed String
certF Text
e
    Right (Certificate
cert :: Certificate) -> do
      let issues :: [Text]
issues = Certificate
-> ProtocolMagicId -> VerificationKey -> VerificationKey -> [Text]
forall a.
ACertificate a
-> ProtocolMagicId -> VerificationKey -> VerificationKey -> [Text]
checkDlgCert Certificate
cert ProtocolMagicId
magic VerificationKey
issuer VerificationKey
delegate
      Bool
-> ExceptT ByronDelegationError IO ()
-> ExceptT ByronDelegationError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
issues) (ExceptT ByronDelegationError IO ()
 -> ExceptT ByronDelegationError IO ())
-> ExceptT ByronDelegationError IO ()
-> ExceptT ByronDelegationError IO ()
forall a b. (a -> b) -> a -> b
$
        ByronDelegationError -> ExceptT ByronDelegationError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ByronDelegationError -> ExceptT ByronDelegationError IO ())
-> ByronDelegationError -> ExceptT ByronDelegationError IO ()
forall a b. (a -> b) -> a -> b
$
          String -> [Text] -> ByronDelegationError
CertificateValidationErrors String
certF [Text]
issues

checkDlgCert
  :: ACertificate a
  -> ProtocolMagicId
  -> Crypto.VerificationKey
  -> Crypto.VerificationKey
  -> [Text]
checkDlgCert :: forall a.
ACertificate a
-> ProtocolMagicId -> VerificationKey -> VerificationKey -> [Text]
checkDlgCert ACertificate a
cert ProtocolMagicId
magic VerificationKey
issuerVK' VerificationKey
delegateVK' =
  [[Text]] -> [Text]
forall a. Monoid a => [a] -> a
mconcat
    [ [ Format Text Text -> Text
forall a. Format Text a -> a
sformat Format Text Text
"Certificate does not have a valid signature."
      | Bool -> Bool
not (Annotated ProtocolMagicId ByteString
-> ACertificate ByteString -> Bool
isValid Annotated ProtocolMagicId ByteString
magic' ACertificate ByteString
cert')
      ]
    , [ Format Text (VerificationKey -> VerificationKey -> Text)
-> VerificationKey -> VerificationKey -> Text
forall a. Format Text a -> a
sformat
          (Format
  (VerificationKey -> VerificationKey -> Text)
  (VerificationKey -> VerificationKey -> Text)
"Certificate issuer " Format
  (VerificationKey -> VerificationKey -> Text)
  (VerificationKey -> VerificationKey -> Text)
-> Format Text (VerificationKey -> VerificationKey -> Text)
-> Format Text (VerificationKey -> VerificationKey -> Text)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (VerificationKey -> Text)
  (VerificationKey -> VerificationKey -> Text)
forall r. Format r (VerificationKey -> r)
vkF Format
  (VerificationKey -> Text)
  (VerificationKey -> VerificationKey -> Text)
-> Format Text (VerificationKey -> Text)
-> Format Text (VerificationKey -> VerificationKey -> Text)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (VerificationKey -> Text) (VerificationKey -> Text)
" doesn't match expected: " Format (VerificationKey -> Text) (VerificationKey -> Text)
-> Format Text (VerificationKey -> Text)
-> Format Text (VerificationKey -> Text)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Text (VerificationKey -> Text)
forall r. Format r (VerificationKey -> r)
vkF)
          (ACertificate a -> VerificationKey
forall a. ACertificate a -> VerificationKey
issuerVK ACertificate a
cert)
          VerificationKey
issuerVK'
      | ACertificate a -> VerificationKey
forall a. ACertificate a -> VerificationKey
issuerVK ACertificate a
cert VerificationKey -> VerificationKey -> Bool
forall a. Eq a => a -> a -> Bool
/= VerificationKey
issuerVK'
      ]
    , [ Format Text (VerificationKey -> VerificationKey -> Text)
-> VerificationKey -> VerificationKey -> Text
forall a. Format Text a -> a
sformat
          (Format
  (VerificationKey -> VerificationKey -> Text)
  (VerificationKey -> VerificationKey -> Text)
"Certificate delegate " Format
  (VerificationKey -> VerificationKey -> Text)
  (VerificationKey -> VerificationKey -> Text)
-> Format Text (VerificationKey -> VerificationKey -> Text)
-> Format Text (VerificationKey -> VerificationKey -> Text)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (VerificationKey -> Text)
  (VerificationKey -> VerificationKey -> Text)
forall r. Format r (VerificationKey -> r)
vkF Format
  (VerificationKey -> Text)
  (VerificationKey -> VerificationKey -> Text)
-> Format Text (VerificationKey -> Text)
-> Format Text (VerificationKey -> VerificationKey -> Text)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (VerificationKey -> Text) (VerificationKey -> Text)
" doesn't match expected: " Format (VerificationKey -> Text) (VerificationKey -> Text)
-> Format Text (VerificationKey -> Text)
-> Format Text (VerificationKey -> Text)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Text (VerificationKey -> Text)
forall r. Format r (VerificationKey -> r)
vkF)
          (ACertificate a -> VerificationKey
forall a. ACertificate a -> VerificationKey
delegateVK ACertificate a
cert)
          VerificationKey
delegateVK'
      | ACertificate a -> VerificationKey
forall a. ACertificate a -> VerificationKey
delegateVK ACertificate a
cert VerificationKey -> VerificationKey -> Bool
forall a. Eq a => a -> a -> Bool
/= VerificationKey
delegateVK'
      ]
    ]
 where
  magic' :: L.Annotated ProtocolMagicId ByteString
  magic' :: Annotated ProtocolMagicId ByteString
magic' = ProtocolMagicId
-> ByteString -> Annotated ProtocolMagicId ByteString
forall b a. b -> a -> Annotated b a
L.Annotated ProtocolMagicId
magic (Version -> ProtocolMagicId -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
L.serialize' Version
L.byronProtVer ProtocolMagicId
magic)

  epoch :: EpochNumber
  epoch :: EpochNumber
epoch = Annotated EpochNumber a -> EpochNumber
forall b a. Annotated b a -> b
L.unAnnotated (Annotated EpochNumber a -> EpochNumber)
-> Annotated EpochNumber a -> EpochNumber
forall a b. (a -> b) -> a -> b
$ ACertificate a -> Annotated EpochNumber a
forall a. ACertificate a -> Annotated EpochNumber a
aEpoch ACertificate a
cert

  cert' :: ACertificate ByteString
  cert' :: ACertificate ByteString
cert' =
    let unannotated :: Certificate
unannotated =
          ACertificate a
cert
            { aEpoch = L.Annotated epoch ()
            , annotation = ()
            }
     in Certificate
unannotated
          { annotation = L.serialize' L.byronProtVer unannotated
          , aEpoch = L.Annotated epoch (L.serialize' L.byronProtVer epoch)
          }

  vkF :: forall r. Format r (Crypto.VerificationKey -> r)
  vkF :: forall r. Format r (VerificationKey -> r)
vkF = Format r (VerificationKey -> r)
forall r. Format r (VerificationKey -> r)
Crypto.fullVerificationKeyF

serialiseDelegationCert :: Certificate -> ByteString
serialiseDelegationCert :: Certificate -> ByteString
serialiseDelegationCert = ByteString -> ByteString
LB.toStrict (ByteString -> ByteString)
-> (Certificate -> ByteString) -> Certificate -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Certificate -> ByteString
forall a. ToJSON Identity a => a -> ByteString
canonicalEncodePretty

serialiseByronWitness :: SomeByronSigningKey -> ByteString
serialiseByronWitness :: SomeByronSigningKey -> ByteString
serialiseByronWitness SomeByronSigningKey
sk =
  case SomeByronSigningKey
sk of
    AByronSigningKeyLegacy SigningKey ByronKeyLegacy
bSkey -> SigningKey ByronKeyLegacy -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes SigningKey ByronKeyLegacy
bSkey
    AByronSigningKey SigningKey ByronKey
legBKey -> SigningKey ByronKey -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes SigningKey ByronKey
legBKey