{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

#if __GLASGOW_HASKELL__ >= 900
-- this is needed for 9.2: recoveryBytes = annotation
{-# OPTIONS_GHC -Wno-ambiguous-fields #-}
#endif

module Cardano.Chain.Update.Proposal (
  -- * Proposal
  AProposal (..),
  Proposal,
  UpId,

  -- * Proposal Constructors
  unsafeProposal,
  signProposal,
  signatureForProposal,

  -- * Proposal Accessors
  body,
  recoverUpId,

  -- * Proposal Formatting
  formatMaybeProposal,

  -- * ProposalBody
  ProposalBody (..),

  -- * ProposalBody Binary Serialization
  recoverProposalSignedBytes,
)
where

import Cardano.Chain.Common.Attributes (dropEmptyAttributes)
import Cardano.Chain.Update.InstallerHash (InstallerHash)
import Cardano.Chain.Update.ProtocolParametersUpdate (ProtocolParametersUpdate)
import Cardano.Chain.Update.ProtocolVersion (ProtocolVersion)
import Cardano.Chain.Update.SoftwareVersion (SoftwareVersion)
import Cardano.Chain.Update.SystemTag (SystemTag)
import Cardano.Crypto (
  Hash,
  ProtocolMagicId,
  SafeSigner,
  SignTag (SignUSProposal),
  Signature,
  VerificationKey,
  hashDecoded,
  safeSign,
  safeToVerification,
  serializeCborHash,
 )
import Cardano.Ledger.Binary (
  ByteSpan,
  DecCBOR (..),
  Decoded (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
 )
import qualified Cardano.Ledger.Binary as Binary
import Cardano.Prelude
import Data.Aeson (ToJSON)
import qualified Data.Map.Strict as M
import Data.Text.Lazy.Builder (Builder)
import Formatting (bprint, build)
import qualified Formatting.Buildable as B

--------------------------------------------------------------------------------
-- Proposal
--------------------------------------------------------------------------------

-- | ID of software update proposal
type UpId = Hash Proposal

-- | Proposal for software update
data AProposal a = AProposal
  { forall a. AProposal a -> Annotated ProposalBody a
aBody :: !(Binary.Annotated ProposalBody a)
  , forall a. AProposal a -> VerificationKey
issuer :: !VerificationKey
  -- ^ Who proposed this UP.
  , forall a. AProposal a -> Signature ProposalBody
signature :: !(Signature ProposalBody)
  , forall a. AProposal a -> a
annotation :: !a
  }
  deriving (AProposal a -> AProposal a -> Bool
forall a. Eq a => AProposal a -> AProposal a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AProposal a -> AProposal a -> Bool
$c/= :: forall a. Eq a => AProposal a -> AProposal a -> Bool
== :: AProposal a -> AProposal a -> Bool
$c== :: forall a. Eq a => AProposal a -> AProposal a -> Bool
Eq, Int -> AProposal a -> ShowS
forall a. Show a => Int -> AProposal a -> ShowS
forall a. Show a => [AProposal a] -> ShowS
forall a. Show a => AProposal a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AProposal a] -> ShowS
$cshowList :: forall a. Show a => [AProposal a] -> ShowS
show :: AProposal a -> String
$cshow :: forall a. Show a => AProposal a -> String
showsPrec :: Int -> AProposal a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> AProposal a -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (AProposal a) x -> AProposal a
forall a x. AProposal a -> Rep (AProposal a) x
$cto :: forall a x. Rep (AProposal a) x -> AProposal a
$cfrom :: forall a x. AProposal a -> Rep (AProposal a) x
Generic, forall a b. a -> AProposal b -> AProposal a
forall a b. (a -> b) -> AProposal a -> AProposal b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> AProposal b -> AProposal a
$c<$ :: forall a b. a -> AProposal b -> AProposal a
fmap :: forall a b. (a -> b) -> AProposal a -> AProposal b
$cfmap :: forall a b. (a -> b) -> AProposal a -> AProposal b
Functor)
  deriving anyclass (forall a. NFData a => AProposal a -> ()
forall a. (a -> ()) -> NFData a
rnf :: AProposal a -> ()
$crnf :: forall a. NFData a => AProposal a -> ()
NFData)

type Proposal = AProposal ()

-- Used for debugging purposes only
instance ToJSON a => ToJSON (AProposal a)

--------------------------------------------------------------------------------
-- Proposal Constructors
--------------------------------------------------------------------------------

-- | Create an update 'Proposal', signing it with the provided safe signer.
signProposal :: ProtocolMagicId -> ProposalBody -> SafeSigner -> Proposal
signProposal :: ProtocolMagicId -> ProposalBody -> SafeSigner -> Proposal
signProposal ProtocolMagicId
protocolMagicId ProposalBody
proposalBody SafeSigner
safeSigner =
  ProposalBody
-> VerificationKey -> Signature ProposalBody -> Proposal
unsafeProposal
    ProposalBody
proposalBody
    (SafeSigner -> VerificationKey
safeToVerification SafeSigner
safeSigner)
    (ProtocolMagicId
-> ProposalBody -> SafeSigner -> Signature ProposalBody
signatureForProposal ProtocolMagicId
protocolMagicId ProposalBody
proposalBody SafeSigner
safeSigner)

signatureForProposal ::
  ProtocolMagicId ->
  ProposalBody ->
  SafeSigner ->
  Signature ProposalBody
signatureForProposal :: ProtocolMagicId
-> ProposalBody -> SafeSigner -> Signature ProposalBody
signatureForProposal ProtocolMagicId
protocolMagicId ProposalBody
proposalBody SafeSigner
safeSigner =
  forall a.
EncCBOR a =>
ProtocolMagicId -> SignTag -> SafeSigner -> a -> Signature a
safeSign ProtocolMagicId
protocolMagicId SignTag
SignUSProposal SafeSigner
safeSigner ProposalBody
proposalBody

-- | Create an update 'Proposal' using the provided signature.
unsafeProposal :: ProposalBody -> VerificationKey -> Signature ProposalBody -> Proposal
unsafeProposal :: ProposalBody
-> VerificationKey -> Signature ProposalBody -> Proposal
unsafeProposal ProposalBody
b VerificationKey
k Signature ProposalBody
s = forall a.
Annotated ProposalBody a
-> VerificationKey -> Signature ProposalBody -> a -> AProposal a
AProposal (forall b a. b -> a -> Annotated b a
Binary.Annotated ProposalBody
b ()) VerificationKey
k Signature ProposalBody
s ()

--------------------------------------------------------------------------------
-- Proposal Accessors
--------------------------------------------------------------------------------

body :: AProposal a -> ProposalBody
body :: forall a. AProposal a -> ProposalBody
body = forall b a. Annotated b a -> b
Binary.unAnnotated forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. AProposal a -> Annotated ProposalBody a
aBody

recoverUpId :: AProposal ByteString -> UpId
recoverUpId :: AProposal ByteString -> UpId
recoverUpId = forall t. Decoded t => t -> Hash (BaseType t)
hashDecoded

--------------------------------------------------------------------------------
-- Proposal Binary Serialization
--------------------------------------------------------------------------------

instance ToCBOR Proposal where
  toCBOR :: Proposal -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
Binary.toByronCBOR

instance FromCBOR Proposal where
  fromCBOR :: forall s. Decoder s Proposal
fromCBOR = forall a s. DecCBOR a => Decoder s a
Binary.fromByronCBOR

instance EncCBOR Proposal where
  encCBOR :: Proposal -> Encoding
encCBOR Proposal
proposal =
    Word -> Encoding
Binary.encodeListLen Word
7
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ProposalBody -> ProtocolVersion
protocolVersion ProposalBody
body')
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ProposalBody -> ProtocolParametersUpdate
protocolParametersUpdate ProposalBody
body')
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ProposalBody -> SoftwareVersion
softwareVersion ProposalBody
body')
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ProposalBody -> Map SystemTag InstallerHash
metadata ProposalBody
body')
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (forall a. Monoid a => a
mempty :: Map Word8 LByteString)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (forall a. AProposal a -> VerificationKey
issuer Proposal
proposal)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (forall a. AProposal a -> Signature ProposalBody
signature Proposal
proposal)
    where
      body' :: ProposalBody
body' = forall a. AProposal a -> ProposalBody
body Proposal
proposal

instance DecCBOR Proposal where
  decCBOR :: forall s. Decoder s Proposal
decCBOR = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR @(AProposal ByteSpan)

instance FromCBOR (AProposal ByteSpan) where
  fromCBOR :: forall s. Decoder s (AProposal ByteSpan)
fromCBOR = forall a s. DecCBOR a => Decoder s a
Binary.fromByronCBOR

instance DecCBOR (AProposal ByteSpan) where
  decCBOR :: forall s. Decoder s (AProposal ByteSpan)
decCBOR = do
    Binary.Annotated (Annotated ProposalBody ByteSpan
pb, VerificationKey
vk, Signature ProposalBody
sig) ByteSpan
byteSpan <- forall s a. Decoder s a -> Decoder s (Annotated a ByteSpan)
Binary.annotatedDecoder forall a b. (a -> b) -> a -> b
$ do
      forall s. Text -> Int -> Decoder s ()
Binary.enforceSize Text
"Proposal" Int
7
      Annotated ProposalBody ByteSpan
pb <-
        forall s a. Decoder s a -> Decoder s (Annotated a ByteSpan)
Binary.annotatedDecoder
          ( ProtocolVersion
-> ProtocolParametersUpdate
-> SoftwareVersion
-> Map SystemTag InstallerHash
-> ProposalBody
ProposalBody
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
              forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s. Dropper s
dropEmptyAttributes
          )
      VerificationKey
vk <- forall a s. DecCBOR a => Decoder s a
decCBOR
      Signature ProposalBody
sig <- forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annotated ProposalBody ByteSpan
pb, VerificationKey
vk, Signature ProposalBody
sig)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
Annotated ProposalBody a
-> VerificationKey -> Signature ProposalBody -> a -> AProposal a
AProposal Annotated ProposalBody ByteSpan
pb VerificationKey
vk Signature ProposalBody
sig ByteSpan
byteSpan

instance Decoded (AProposal ByteString) where
  type BaseType (AProposal ByteString) = Proposal
  recoverBytes :: AProposal ByteString -> ByteString
recoverBytes = forall a. AProposal a -> a
annotation

--------------------------------------------------------------------------------
-- Proposal Formatting
--------------------------------------------------------------------------------

instance B.Buildable (AProposal ()) where
  build :: Proposal -> Builder
build Proposal
proposal =
    forall a. Format Builder a -> a
bprint
      ( 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
  (ProtocolVersion
   -> UpId -> ProtocolParametersUpdate -> [SystemTag] -> Builder)
  (ProtocolVersion
   -> UpId -> ProtocolParametersUpdate -> [SystemTag] -> Builder)
" { block v"
          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
  (UpId -> ProtocolParametersUpdate -> [SystemTag] -> Builder)
  (UpId -> ProtocolParametersUpdate -> [SystemTag] -> Builder)
", UpId: "
          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
  (ProtocolParametersUpdate -> [SystemTag] -> Builder)
  (ProtocolParametersUpdate -> [SystemTag] -> Builder)
", "
          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 ([SystemTag] -> Builder) ([SystemTag] -> Builder)
", tags: "
          forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (t :: * -> *) a r.
(Foldable t, Buildable a) =>
Format r (t a -> r)
listJson
          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
" }"
      )
      (ProposalBody -> SoftwareVersion
softwareVersion ProposalBody
body')
      (ProposalBody -> ProtocolVersion
protocolVersion ProposalBody
body')
      (forall a. EncCBOR a => a -> Hash a
serializeCborHash Proposal
proposal)
      (ProposalBody -> ProtocolParametersUpdate
protocolParametersUpdate ProposalBody
body')
      (forall k a. Map k a -> [k]
M.keys forall a b. (a -> b) -> a -> b
$ ProposalBody -> Map SystemTag InstallerHash
metadata ProposalBody
body')
    where
      body' :: ProposalBody
body' = forall a. AProposal a -> ProposalBody
body Proposal
proposal

formatMaybeProposal :: Maybe Proposal -> Builder
formatMaybeProposal :: Maybe Proposal -> Builder
formatMaybeProposal = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
"no proposal" forall p. Buildable p => p -> Builder
B.build

--------------------------------------------------------------------------------
-- ProposalBody
--------------------------------------------------------------------------------

data ProposalBody = ProposalBody
  { ProposalBody -> ProtocolVersion
protocolVersion :: !ProtocolVersion
  , ProposalBody -> ProtocolParametersUpdate
protocolParametersUpdate :: !ProtocolParametersUpdate
  , ProposalBody -> SoftwareVersion
softwareVersion :: !SoftwareVersion
  , ProposalBody -> Map SystemTag InstallerHash
metadata :: !(Map SystemTag InstallerHash)
  -- ^ InstallerHash for each system which this update affects
  }
  deriving (ProposalBody -> ProposalBody -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProposalBody -> ProposalBody -> Bool
$c/= :: ProposalBody -> ProposalBody -> Bool
== :: ProposalBody -> ProposalBody -> Bool
$c== :: ProposalBody -> ProposalBody -> Bool
Eq, Int -> ProposalBody -> ShowS
[ProposalBody] -> ShowS
ProposalBody -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProposalBody] -> ShowS
$cshowList :: [ProposalBody] -> ShowS
show :: ProposalBody -> String
$cshow :: ProposalBody -> String
showsPrec :: Int -> ProposalBody -> ShowS
$cshowsPrec :: Int -> ProposalBody -> ShowS
Show, forall x. Rep ProposalBody x -> ProposalBody
forall x. ProposalBody -> Rep ProposalBody x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ProposalBody x -> ProposalBody
$cfrom :: forall x. ProposalBody -> Rep ProposalBody x
Generic)
  deriving anyclass (ProposalBody -> ()
forall a. (a -> ()) -> NFData a
rnf :: ProposalBody -> ()
$crnf :: ProposalBody -> ()
NFData)

-- Used for debugging purposes only
instance ToJSON ProposalBody

--------------------------------------------------------------------------------
-- ProposalBody Binary Serialization
--------------------------------------------------------------------------------

instance ToCBOR ProposalBody where
  toCBOR :: ProposalBody -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
Binary.toByronCBOR

instance FromCBOR ProposalBody where
  fromCBOR :: forall s. Decoder s ProposalBody
fromCBOR = forall a s. DecCBOR a => Decoder s a
Binary.fromByronCBOR

instance EncCBOR ProposalBody where
  encCBOR :: ProposalBody -> Encoding
encCBOR ProposalBody
pb =
    Word -> Encoding
Binary.encodeListLen Word
5
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ProposalBody -> ProtocolVersion
protocolVersion ProposalBody
pb)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ProposalBody -> ProtocolParametersUpdate
protocolParametersUpdate ProposalBody
pb)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ProposalBody -> SoftwareVersion
softwareVersion ProposalBody
pb)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ProposalBody -> Map SystemTag InstallerHash
metadata ProposalBody
pb)
      -- Encode empty Attributes
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (forall a. Monoid a => a
mempty :: Map Word8 LByteString)

instance DecCBOR ProposalBody where
  decCBOR :: forall s. Decoder s ProposalBody
decCBOR = do
    forall s. Text -> Int -> Decoder s ()
Binary.enforceSize Text
"ProposalBody" Int
5
    ProtocolVersion
-> ProtocolParametersUpdate
-> SoftwareVersion
-> Map SystemTag InstallerHash
-> ProposalBody
ProposalBody
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s. Dropper s
dropEmptyAttributes

-- | Prepend byte corresponding to `encodeListLen 5`, which was used during
--   signing
recoverProposalSignedBytes ::
  Binary.Annotated ProposalBody ByteString -> Binary.Annotated ProposalBody ByteString
recoverProposalSignedBytes :: Annotated ProposalBody ByteString
-> Annotated ProposalBody ByteString
recoverProposalSignedBytes = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString
"\133" forall a. Semigroup a => a -> a -> a
<>)