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

module Bcc.CLI.Cole.Delegation
  ( ColeDelegationError(..)
  , checkColeGenesisDelegation
  , issueColeGenesisDelegation
  , renderColeDelegationError
  , serialiseDelegationCert
  , serialiseColeWitness
  )
where

import           Bcc.Prelude hiding (option, show, trace)

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

import           Bcc.Api.Cole

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

import           Bcc.CLI.Cole.Key (ColeKeyFailure, renderColeKeyFailure)
import           Bcc.CLI.Helpers (textShow)
import           Bcc.CLI.Types (CertificateFile (..))

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

renderColeDelegationError :: ColeDelegationError -> Text
renderColeDelegationError :: ColeDelegationError -> Text
renderColeDelegationError ColeDelegationError
err =
  case ColeDelegationError
err of
    CertificateValidationErrors String
certFp [Text]
errs ->
      Text
"Certificate validation error(s) at: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
textShow String
certFp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Errors: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Show a => a -> Text
textShow [Text]
errs
    DlgCertificateDeserialisationFailed String
certFp Text
deSererr ->
      Text
"Certificate deserialisation error at: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
textShow String
certFp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
textShow Text
deSererr
    ColeDelegationKeyError ColeKeyFailure
kerr -> ColeKeyFailure -> Text
renderColeKeyFailure ColeKeyFailure
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.
issueColeGenesisDelegation
  :: ProtocolMagicId
  -> EpochNumber
  -> Crypto.SigningKey
  -> Crypto.VerificationKey
  -> Dlg.Certificate
issueColeGenesisDelegation :: ProtocolMagicId
-> EpochNumber -> SigningKey -> VerificationKey -> Certificate
issueColeGenesisDelegation ProtocolMagicId
magic EpochNumber
epoch SigningKey
issuerSK VerificationKey
delegateVK =
  ProtocolMagicId
-> VerificationKey -> EpochNumber -> SafeSigner -> Certificate
Dlg.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.
checkColeGenesisDelegation
  :: CertificateFile
  -> ProtocolMagicId
  -> Crypto.VerificationKey
  -> Crypto.VerificationKey
  -> ExceptT ColeDelegationError IO ()
checkColeGenesisDelegation :: CertificateFile
-> ProtocolMagicId
-> VerificationKey
-> VerificationKey
-> ExceptT ColeDelegationError IO ()
checkColeGenesisDelegation (CertificateFile String
certF) ProtocolMagicId
magic VerificationKey
issuer VerificationKey
delegate = do
  Either Text Certificate
ecert <- IO (Either Text Certificate)
-> ExceptT ColeDelegationError IO (Either Text Certificate)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Certificate)
 -> ExceptT ColeDelegationError IO (Either Text Certificate))
-> IO (Either Text Certificate)
-> ExceptT ColeDelegationError 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 -> ColeDelegationError -> ExceptT ColeDelegationError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ColeDelegationError -> ExceptT ColeDelegationError IO ())
-> ColeDelegationError -> ExceptT ColeDelegationError IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> ColeDelegationError
DlgCertificateDeserialisationFailed String
certF Text
e
    Right (Certificate
cert :: Dlg.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 ColeDelegationError IO ()
-> ExceptT ColeDelegationError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
issues) (ExceptT ColeDelegationError IO ()
 -> ExceptT ColeDelegationError IO ())
-> ExceptT ColeDelegationError IO ()
-> ExceptT ColeDelegationError IO ()
forall a b. (a -> b) -> a -> b
$
        ColeDelegationError -> ExceptT ColeDelegationError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ColeDelegationError -> ExceptT ColeDelegationError IO ())
-> ColeDelegationError -> ExceptT ColeDelegationError IO ()
forall a b. (a -> b) -> a -> b
$ String -> [Text] -> ColeDelegationError
CertificateValidationErrors String
certF [Text]
issues

checkDlgCert
  :: Dlg.ACertificate a
  -> ProtocolMagicId
  -> Crypto.VerificationKey
  -> Crypto.VerificationKey -> [Text]
checkDlgCert :: 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
Dlg.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 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)
vkFFormat
  (VerificationKey -> Text)
  (VerificationKey -> VerificationKey -> Text)
-> Format Text (VerificationKey -> Text)
-> Format Text (VerificationKey -> VerificationKey -> Text)
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 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
Dlg.issuerVK ACertificate a
cert) VerificationKey
issuerVK'
      | ACertificate a -> VerificationKey
forall a. ACertificate a -> VerificationKey
Dlg.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 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)
vkFFormat
  (VerificationKey -> Text)
  (VerificationKey -> VerificationKey -> Text)
-> Format Text (VerificationKey -> Text)
-> Format Text (VerificationKey -> VerificationKey -> Text)
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 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
Dlg.delegateVK ACertificate a
cert) VerificationKey
delegateVK'
      | ACertificate a -> VerificationKey
forall a. ACertificate a -> VerificationKey
Dlg.delegateVK ACertificate a
cert VerificationKey -> VerificationKey -> Bool
forall a. Eq a => a -> a -> Bool
/= VerificationKey
delegateVK'
    ]
  ]
  where
    magic' :: Annotated ProtocolMagicId ByteString
    magic' :: Annotated ProtocolMagicId ByteString
magic' = ProtocolMagicId
-> ByteString -> Annotated ProtocolMagicId ByteString
forall b a. b -> a -> Annotated b a
Annotated ProtocolMagicId
magic (ProtocolMagicId -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' ProtocolMagicId
magic)

    epoch :: EpochNumber
    epoch :: EpochNumber
epoch = Annotated EpochNumber a -> EpochNumber
forall b a. Annotated b a -> b
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
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 = EpochNumber -> () -> Annotated EpochNumber ()
forall b a. b -> a -> Annotated b a
Annotated EpochNumber
epoch ()
                             , annotation :: ()
Dlg.annotation = () }
      in Certificate
unannotated { annotation :: ByteString
Dlg.annotation = Certificate -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' Certificate
unannotated
                     , aEpoch :: Annotated EpochNumber ByteString
Dlg.aEpoch = EpochNumber -> ByteString -> Annotated EpochNumber ByteString
forall b a. b -> a -> Annotated b a
Annotated EpochNumber
epoch (EpochNumber -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' EpochNumber
epoch) }

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


serialiseDelegationCert :: Dlg.Certificate -> ByteString
serialiseDelegationCert :: Certificate -> ByteString
serialiseDelegationCert = ByteString -> ByteString
LB.toStrict (ByteString -> ByteString)
-> (Certificate -> ByteString) -> Certificate -> ByteString
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

serialiseColeWitness :: SomeColeSigningKey -> ByteString
serialiseColeWitness :: SomeColeSigningKey -> ByteString
serialiseColeWitness SomeColeSigningKey
sk =
  case SomeColeSigningKey
sk of
    AColeSigningKeyLegacy SigningKey ColeKeyLegacy
bSkey -> SigningKey ColeKeyLegacy -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes SigningKey ColeKeyLegacy
bSkey
    AColeSigningKey SigningKey ColeKey
legBKey -> SigningKey ColeKey -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes SigningKey ColeKey
legBKey