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

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

import           Prelude hiding ((.))

import           Control.Category
import           Control.Monad.Trans.Except.Extra (left)
import qualified Data.ByteString.Lazy as LB
import           Formatting (Format, sformat)

import           Cardano.Api.Byron

import           Cardano.Binary (Annotated (..), serialize')
import qualified Cardano.Chain.Delegation as Dlg
import           Cardano.Chain.Slotting (EpochNumber)
import           Cardano.Crypto (ProtocolMagicId)
import qualified Cardano.Crypto as Crypto

import           Cardano.CLI.Byron.Key (ByronKeyFailure, renderByronKeyFailure)
import           Cardano.CLI.Types (CertificateFile (..))
import           Cardano.Prelude (canonicalDecodePretty, canonicalEncodePretty)
import           Control.Monad (unless)
import           Control.Monad.IO.Class (MonadIO (..))
import           Control.Monad.Trans.Except (ExceptT)
import           Data.ByteString (ByteString)
import           Data.Text (Text)

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

renderByronDelegationError :: ByronDelegationError -> Text
renderByronDelegationError :: ByronDelegationError -> Text
renderByronDelegationError ByronDelegationError
err =
  case ByronDelegationError
err of
    CertificateValidationErrors FilePath
certFp [Text]
errs ->
      Text
"Certificate validation error(s) at: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow FilePath
certFp forall a. Semigroup a => a -> a -> a
<> Text
" Errors: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow [Text]
errs
    DlgCertificateDeserialisationFailed FilePath
certFp Text
deSererr ->
      Text
"Certificate deserialisation error at: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow FilePath
certFp forall a. Semigroup a => a -> a -> a
<> Text
" Error: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow Text
deSererr
    ByronDelegationKeyError ByronKeyFailure
kerr -> ByronKeyFailure -> Text
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
  -> Dlg.Certificate
issueByronGenesisDelegation :: ProtocolMagicId
-> EpochNumber -> SigningKey -> VerificationKey -> Certificate
issueByronGenesisDelegation ProtocolMagicId
magic EpochNumber
epoch SigningKey
issuerSK VerificationKey
delegateVK =
  ProtocolMagicId
-> VerificationKey -> EpochNumber -> SafeSigner -> Certificate
Dlg.signCertificate ProtocolMagicId
magic VerificationKey
delegateVK EpochNumber
epoch 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 FilePath
certF) ProtocolMagicId
magic VerificationKey
issuer VerificationKey
delegate = do
  Either Text Certificate
ecert <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
FromJSON (Either SchemaError) a =>
ByteString -> Either Text a
canonicalDecodePretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
LB.readFile FilePath
certF
  case Either Text Certificate
ecert of
    Left Text
e -> forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> ByronDelegationError
DlgCertificateDeserialisationFailed FilePath
certF Text
e
    Right (Certificate
cert :: Dlg.Certificate) -> do
      let issues :: [Text]
issues = forall a.
ACertificate a
-> ProtocolMagicId -> VerificationKey -> VerificationKey -> [Text]
checkDlgCert Certificate
cert ProtocolMagicId
magic VerificationKey
issuer VerificationKey
delegate
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
issues) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall a b. (a -> b) -> a -> b
$ FilePath -> [Text] -> ByronDelegationError
CertificateValidationErrors FilePath
certF [Text]
issues

checkDlgCert
  :: Dlg.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' =
  forall a. Monoid a => [a] -> a
mconcat
  [ [ 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
Dlg.isValid Annotated ProtocolMagicId ByteString
magic' ACertificate ByteString
cert')
    ]
  , [ forall a. Format Text a -> a
sformat (Format
  (VerificationKey -> VerificationKey -> Text)
  (VerificationKey -> VerificationKey -> Text)
"Certificate issuer "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)
vkFforall {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: "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)
vkF)
      ( forall a. ACertificate a -> VerificationKey
Dlg.issuerVK ACertificate a
cert) VerificationKey
issuerVK'
      | forall a. ACertificate a -> VerificationKey
Dlg.issuerVK ACertificate a
cert forall a. Eq a => a -> a -> Bool
/= VerificationKey
issuerVK'
    ]
  , [ forall a. Format Text a -> a
sformat (Format
  (VerificationKey -> VerificationKey -> Text)
  (VerificationKey -> VerificationKey -> Text)
"Certificate delegate "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)
vkFforall {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: "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)
vkF)
      ( forall a. ACertificate a -> VerificationKey
Dlg.delegateVK ACertificate a
cert) VerificationKey
delegateVK'
      | forall a. ACertificate a -> VerificationKey
Dlg.delegateVK ACertificate a
cert forall a. Eq a => a -> a -> Bool
/= VerificationKey
delegateVK'
    ]
  ]
  where
    magic' :: Annotated ProtocolMagicId ByteString
    magic' :: Annotated ProtocolMagicId ByteString
magic' = forall b a. b -> a -> Annotated b a
Annotated ProtocolMagicId
magic (forall a. ToCBOR a => a -> ByteString
serialize' ProtocolMagicId
magic)

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

    cert' :: Dlg.ACertificate ByteString
    cert' :: ACertificate ByteString
cert' =
      let unannotated :: Certificate
unannotated = ACertificate a
cert { aEpoch :: Annotated EpochNumber ()
Dlg.aEpoch = forall b a. b -> a -> Annotated b a
Annotated EpochNumber
epoch ()
                             , annotation :: ()
Dlg.annotation = () }
      in Certificate
unannotated { annotation :: ByteString
Dlg.annotation = forall a. ToCBOR a => a -> ByteString
serialize' Certificate
unannotated
                     , aEpoch :: Annotated EpochNumber ByteString
Dlg.aEpoch = forall b a. b -> a -> Annotated b a
Annotated EpochNumber
epoch (forall a. ToCBOR a => a -> ByteString
serialize' EpochNumber
epoch) }

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


serialiseDelegationCert :: Dlg.Certificate -> ByteString
serialiseDelegationCert :: Certificate -> ByteString
serialiseDelegationCert = ByteString -> ByteString
LB.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. ToJSON Identity a => a -> ByteString
canonicalEncodePretty

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