{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Validation rules for registering updates
--
--   This is an implementation of the rules defined in the Byron ledger
--   specification
module Cardano.Chain.Update.Validation.Registration (
  Error (..),
  Environment (..),
  State (..),
  ApplicationVersion (..),
  ApplicationVersions,
  Metadata,
  ProtocolUpdateProposal (..),
  ProtocolUpdateProposals,
  SoftwareUpdateProposal (..),
  SoftwareUpdateProposals,
  registerProposal,
  TooLarge (..),
  Adopted (..),
)
where

import Cardano.Chain.Common (KeyHash, hashKey)
import qualified Cardano.Chain.Delegation as Delegation
import Cardano.Chain.Slotting (SlotNumber (SlotNumber))
import Cardano.Chain.Update.ApplicationName (ApplicationName)
import Cardano.Chain.Update.InstallerHash (InstallerHash)
import Cardano.Chain.Update.Proposal (
  AProposal (..),
  ProposalBody (..),
  UpId,
  protocolParametersUpdate,
  protocolVersion,
  recoverProposalSignedBytes,
  recoverUpId,
  softwareVersion,
 )
import qualified Cardano.Chain.Update.Proposal as Proposal
import Cardano.Chain.Update.ProtocolParameters (
  ProtocolParameters,
  ppMaxBlockSize,
  ppMaxProposalSize,
  ppMaxTxSize,
  ppScriptVersion,
 )
import qualified Cardano.Chain.Update.ProtocolParametersUpdate as PPU
import Cardano.Chain.Update.ProtocolVersion (ProtocolVersion (ProtocolVersion))
import Cardano.Chain.Update.SoftwareVersion (
  NumSoftwareVersion,
  SoftwareVersion (SoftwareVersion),
  SoftwareVersionError,
  checkSoftwareVersion,
  svAppName,
 )
import Cardano.Chain.Update.SystemTag (SystemTag, SystemTagError, checkSystemTag)
import Cardano.Crypto (
  ProtocolMagicId (..),
  SignTag (SignUSProposal),
  verifySignatureDecoded,
 )
import Cardano.Ledger.Binary (
  Annotated (unAnnotated),
  DecCBOR (..),
  Decoder,
  DecoderError (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  cborError,
  decodeListLen,
  decodeWord8,
  encodeListLen,
  enforceSize,
  fromByronCBOR,
  matchSize,
  toByronCBOR,
 )
import Cardano.Prelude hiding (State, cborError)
import qualified Data.ByteString as BS
import qualified Data.Map.Strict as M
import NoThunks.Class (NoThunks (..))

data Environment = Environment
  { Environment -> Annotated ProtocolMagicId ByteString
protocolMagic :: !(Annotated ProtocolMagicId ByteString)
  , Environment -> SlotNumber
currentSlot :: !SlotNumber
  , Environment -> ProtocolVersion
adoptedProtocolVersion :: !ProtocolVersion
  , Environment -> ProtocolParameters
adoptedProtocolParameters :: !ProtocolParameters
  , Environment -> ApplicationVersions
appVersions :: !ApplicationVersions
  , Environment -> Map
delegationMap :: !Delegation.Map
  }

data ApplicationVersion = ApplicationVersion
  { ApplicationVersion -> NumSoftwareVersion
avNumSoftwareVersion :: !NumSoftwareVersion
  , ApplicationVersion -> SlotNumber
avSlotNumber :: !SlotNumber
  , ApplicationVersion -> Metadata
avMetadata :: !Metadata
  }
  deriving (ApplicationVersion -> ApplicationVersion -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApplicationVersion -> ApplicationVersion -> Bool
$c/= :: ApplicationVersion -> ApplicationVersion -> Bool
== :: ApplicationVersion -> ApplicationVersion -> Bool
$c== :: ApplicationVersion -> ApplicationVersion -> Bool
Eq, Int -> ApplicationVersion -> ShowS
[ApplicationVersion] -> ShowS
ApplicationVersion -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApplicationVersion] -> ShowS
$cshowList :: [ApplicationVersion] -> ShowS
show :: ApplicationVersion -> String
$cshow :: ApplicationVersion -> String
showsPrec :: Int -> ApplicationVersion -> ShowS
$cshowsPrec :: Int -> ApplicationVersion -> ShowS
Show, forall x. Rep ApplicationVersion x -> ApplicationVersion
forall x. ApplicationVersion -> Rep ApplicationVersion x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ApplicationVersion x -> ApplicationVersion
$cfrom :: forall x. ApplicationVersion -> Rep ApplicationVersion x
Generic)
  deriving anyclass (ApplicationVersion -> ()
forall a. (a -> ()) -> NFData a
rnf :: ApplicationVersion -> ()
$crnf :: ApplicationVersion -> ()
NFData, Context -> ApplicationVersion -> IO (Maybe ThunkInfo)
Proxy ApplicationVersion -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy ApplicationVersion -> String
$cshowTypeOf :: Proxy ApplicationVersion -> String
wNoThunks :: Context -> ApplicationVersion -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ApplicationVersion -> IO (Maybe ThunkInfo)
noThunks :: Context -> ApplicationVersion -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> ApplicationVersion -> IO (Maybe ThunkInfo)
NoThunks)

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

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

instance DecCBOR ApplicationVersion where
  decCBOR :: forall s. Decoder s ApplicationVersion
decCBOR = do
    forall s. Text -> Int -> Decoder s ()
enforceSize Text
"ApplicationVersion" Int
3
    NumSoftwareVersion -> SlotNumber -> Metadata -> ApplicationVersion
ApplicationVersion 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

instance EncCBOR ApplicationVersion where
  encCBOR :: ApplicationVersion -> Encoding
encCBOR ApplicationVersion
av =
    Word -> Encoding
encodeListLen Word
3
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ApplicationVersion -> NumSoftwareVersion
avNumSoftwareVersion ApplicationVersion
av)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ApplicationVersion -> SlotNumber
avSlotNumber ApplicationVersion
av)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ApplicationVersion -> Metadata
avMetadata ApplicationVersion
av)

type ApplicationVersions = Map ApplicationName ApplicationVersion

type Metadata = Map SystemTag InstallerHash

-- | State keeps track of registered protocol and software update
--   proposals
data State = State
  { State -> ProtocolUpdateProposals
rsProtocolUpdateProposals :: !ProtocolUpdateProposals
  , State -> SoftwareUpdateProposals
rsSoftwareUpdateProposals :: !SoftwareUpdateProposals
  }

data ProtocolUpdateProposal = ProtocolUpdateProposal
  { ProtocolUpdateProposal -> ProtocolVersion
pupProtocolVersion :: !ProtocolVersion
  , ProtocolUpdateProposal -> ProtocolParameters
pupProtocolParameters :: !ProtocolParameters
  }
  deriving (ProtocolUpdateProposal -> ProtocolUpdateProposal -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProtocolUpdateProposal -> ProtocolUpdateProposal -> Bool
$c/= :: ProtocolUpdateProposal -> ProtocolUpdateProposal -> Bool
== :: ProtocolUpdateProposal -> ProtocolUpdateProposal -> Bool
$c== :: ProtocolUpdateProposal -> ProtocolUpdateProposal -> Bool
Eq, Int -> ProtocolUpdateProposal -> ShowS
[ProtocolUpdateProposal] -> ShowS
ProtocolUpdateProposal -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProtocolUpdateProposal] -> ShowS
$cshowList :: [ProtocolUpdateProposal] -> ShowS
show :: ProtocolUpdateProposal -> String
$cshow :: ProtocolUpdateProposal -> String
showsPrec :: Int -> ProtocolUpdateProposal -> ShowS
$cshowsPrec :: Int -> ProtocolUpdateProposal -> ShowS
Show, forall x. Rep ProtocolUpdateProposal x -> ProtocolUpdateProposal
forall x. ProtocolUpdateProposal -> Rep ProtocolUpdateProposal x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ProtocolUpdateProposal x -> ProtocolUpdateProposal
$cfrom :: forall x. ProtocolUpdateProposal -> Rep ProtocolUpdateProposal x
Generic)
  deriving anyclass (ProtocolUpdateProposal -> ()
forall a. (a -> ()) -> NFData a
rnf :: ProtocolUpdateProposal -> ()
$crnf :: ProtocolUpdateProposal -> ()
NFData, Context -> ProtocolUpdateProposal -> IO (Maybe ThunkInfo)
Proxy ProtocolUpdateProposal -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy ProtocolUpdateProposal -> String
$cshowTypeOf :: Proxy ProtocolUpdateProposal -> String
wNoThunks :: Context -> ProtocolUpdateProposal -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ProtocolUpdateProposal -> IO (Maybe ThunkInfo)
noThunks :: Context -> ProtocolUpdateProposal -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> ProtocolUpdateProposal -> IO (Maybe ThunkInfo)
NoThunks)

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

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

instance DecCBOR ProtocolUpdateProposal where
  decCBOR :: forall s. Decoder s ProtocolUpdateProposal
decCBOR = do
    forall s. Text -> Int -> Decoder s ()
enforceSize Text
"ProtocolUpdateProposal" Int
2
    ProtocolVersion -> ProtocolParameters -> ProtocolUpdateProposal
ProtocolUpdateProposal 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

instance EncCBOR ProtocolUpdateProposal where
  encCBOR :: ProtocolUpdateProposal -> Encoding
encCBOR ProtocolUpdateProposal
pup =
    Word -> Encoding
encodeListLen Word
2
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ProtocolUpdateProposal -> ProtocolVersion
pupProtocolVersion ProtocolUpdateProposal
pup)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (ProtocolUpdateProposal -> ProtocolParameters
pupProtocolParameters ProtocolUpdateProposal
pup)

type ProtocolUpdateProposals = Map UpId ProtocolUpdateProposal

data SoftwareUpdateProposal = SoftwareUpdateProposal
  { SoftwareUpdateProposal -> SoftwareVersion
supSoftwareVersion :: !SoftwareVersion
  , SoftwareUpdateProposal -> Metadata
supSoftwareMetadata :: !Metadata
  }
  deriving (SoftwareUpdateProposal -> SoftwareUpdateProposal -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SoftwareUpdateProposal -> SoftwareUpdateProposal -> Bool
$c/= :: SoftwareUpdateProposal -> SoftwareUpdateProposal -> Bool
== :: SoftwareUpdateProposal -> SoftwareUpdateProposal -> Bool
$c== :: SoftwareUpdateProposal -> SoftwareUpdateProposal -> Bool
Eq, Int -> SoftwareUpdateProposal -> ShowS
[SoftwareUpdateProposal] -> ShowS
SoftwareUpdateProposal -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SoftwareUpdateProposal] -> ShowS
$cshowList :: [SoftwareUpdateProposal] -> ShowS
show :: SoftwareUpdateProposal -> String
$cshow :: SoftwareUpdateProposal -> String
showsPrec :: Int -> SoftwareUpdateProposal -> ShowS
$cshowsPrec :: Int -> SoftwareUpdateProposal -> ShowS
Show, forall x. Rep SoftwareUpdateProposal x -> SoftwareUpdateProposal
forall x. SoftwareUpdateProposal -> Rep SoftwareUpdateProposal x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SoftwareUpdateProposal x -> SoftwareUpdateProposal
$cfrom :: forall x. SoftwareUpdateProposal -> Rep SoftwareUpdateProposal x
Generic)
  deriving anyclass (SoftwareUpdateProposal -> ()
forall a. (a -> ()) -> NFData a
rnf :: SoftwareUpdateProposal -> ()
$crnf :: SoftwareUpdateProposal -> ()
NFData, Context -> SoftwareUpdateProposal -> IO (Maybe ThunkInfo)
Proxy SoftwareUpdateProposal -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy SoftwareUpdateProposal -> String
$cshowTypeOf :: Proxy SoftwareUpdateProposal -> String
wNoThunks :: Context -> SoftwareUpdateProposal -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> SoftwareUpdateProposal -> IO (Maybe ThunkInfo)
noThunks :: Context -> SoftwareUpdateProposal -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> SoftwareUpdateProposal -> IO (Maybe ThunkInfo)
NoThunks)

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

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

instance DecCBOR SoftwareUpdateProposal where
  decCBOR :: forall s. Decoder s SoftwareUpdateProposal
decCBOR = do
    forall s. Text -> Int -> Decoder s ()
enforceSize Text
"SoftwareUpdateProposal" Int
2
    SoftwareVersion -> Metadata -> SoftwareUpdateProposal
SoftwareUpdateProposal 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

instance EncCBOR SoftwareUpdateProposal where
  encCBOR :: SoftwareUpdateProposal -> Encoding
encCBOR SoftwareUpdateProposal
sup =
    Word -> Encoding
encodeListLen Word
2
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (SoftwareUpdateProposal -> SoftwareVersion
supSoftwareVersion SoftwareUpdateProposal
sup)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (SoftwareUpdateProposal -> Metadata
supSoftwareMetadata SoftwareUpdateProposal
sup)

type SoftwareUpdateProposals = Map UpId SoftwareUpdateProposal

-- | Error captures the ways in which registration could fail
data Error
  = DuplicateProtocolVersion ProtocolVersion
  | DuplicateSoftwareVersion SoftwareVersion
  | InvalidProposer KeyHash
  | InvalidProtocolVersion ProtocolVersion Adopted
  | InvalidScriptVersion Word16 Word16
  | InvalidSignature
  | InvalidSoftwareVersion ApplicationVersions SoftwareVersion
  | MaxBlockSizeTooLarge (TooLarge Natural)
  | MaxTxSizeTooLarge (TooLarge Natural)
  | ProposalAttributesUnknown
  | ProposalTooLarge (TooLarge Natural)
  | SoftwareVersionError SoftwareVersionError
  | SystemTagError SystemTagError
  | -- | The update proposal proposes neither a bump in the protocol or
    -- application versions.
    NullUpdateProposal
  deriving (Error -> Error -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)

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

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

instance EncCBOR Error where
  encCBOR :: Error -> Encoding
encCBOR Error
err = case Error
err of
    DuplicateProtocolVersion ProtocolVersion
protocolVersion ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
0 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR ProtocolVersion
protocolVersion
    DuplicateSoftwareVersion SoftwareVersion
softwareVersion ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
1 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR SoftwareVersion
softwareVersion
    InvalidProposer KeyHash
keyHash ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
2 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash
keyHash
    InvalidProtocolVersion ProtocolVersion
protocolVersion Adopted
adopted ->
      Word -> Encoding
encodeListLen Word
3
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
3 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR ProtocolVersion
protocolVersion
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Adopted
adopted
    InvalidScriptVersion Word16
adoptedScriptVersion Word16
newScriptVersion ->
      Word -> Encoding
encodeListLen Word
3
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
4 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Word16
adoptedScriptVersion
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Word16
newScriptVersion
    Error
InvalidSignature ->
      Word -> Encoding
encodeListLen Word
1
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
5 :: Word8)
    InvalidSoftwareVersion ApplicationVersions
applicationVersions SoftwareVersion
softwareVersion ->
      Word -> Encoding
encodeListLen Word
3
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
6 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR ApplicationVersions
applicationVersions
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR SoftwareVersion
softwareVersion
    MaxBlockSizeTooLarge TooLarge Natural
tooLarge ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
7 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR TooLarge Natural
tooLarge
    MaxTxSizeTooLarge TooLarge Natural
tooLarge ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
8 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR TooLarge Natural
tooLarge
    Error
ProposalAttributesUnknown ->
      Word -> Encoding
encodeListLen Word
1
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
9 :: Word8)
    ProposalTooLarge TooLarge Natural
tooLarge ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
10 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR TooLarge Natural
tooLarge
    SoftwareVersionError SoftwareVersionError
softwareVersionError ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
11 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR SoftwareVersionError
softwareVersionError
    SystemTagError SystemTagError
systemTagError ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
12 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR SystemTagError
systemTagError
    Error
NullUpdateProposal ->
      Word -> Encoding
encodeListLen Word
1
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
13 :: Word8)

instance DecCBOR Error where
  decCBOR :: forall s. Decoder s Error
decCBOR = do
    Int
len <- forall s. Decoder s Int
decodeListLen
    let checkSize :: Int -> Decoder s ()
        checkSize :: forall s. Int -> Decoder s ()
checkSize Int
size = forall s. Text -> Int -> Int -> Decoder s ()
matchSize Text
"Registration.Error" Int
size Int
len
    Word8
tag <- forall s. Decoder s Word8
decodeWord8
    case Word8
tag of
      Word8
0 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProtocolVersion -> Error
DuplicateProtocolVersion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
1 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SoftwareVersion -> Error
DuplicateSoftwareVersion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
2 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> KeyHash -> Error
InvalidProposer forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
3 -> forall s. Int -> Decoder s ()
checkSize Int
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProtocolVersion -> Adopted -> Error
InvalidProtocolVersion 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
      Word8
4 -> forall s. Int -> Decoder s ()
checkSize Int
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Word16 -> Error
InvalidScriptVersion 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
      Word8
5 -> forall s. Int -> Decoder s ()
checkSize Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Error
InvalidSignature
      Word8
6 -> forall s. Int -> Decoder s ()
checkSize Int
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ApplicationVersions -> SoftwareVersion -> Error
InvalidSoftwareVersion 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
      Word8
7 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TooLarge Natural -> Error
MaxBlockSizeTooLarge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
8 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TooLarge Natural -> Error
MaxTxSizeTooLarge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
9 -> forall s. Int -> Decoder s ()
checkSize Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Error
ProposalAttributesUnknown
      Word8
10 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TooLarge Natural -> Error
ProposalTooLarge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
11 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SoftwareVersionError -> Error
SoftwareVersionError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
12 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SystemTagError -> Error
SystemTagError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
13 -> forall s. Int -> Decoder s ()
checkSize Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Error
NullUpdateProposal
      Word8
_ -> forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"Registration.Error" Word8
tag

data TooLarge n = TooLarge
  { forall n. TooLarge n -> n
tlActual :: n
  , forall n. TooLarge n -> n
tlMaxBound :: n
  }
  deriving (TooLarge n -> TooLarge n -> Bool
forall n. Eq n => TooLarge n -> TooLarge n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TooLarge n -> TooLarge n -> Bool
$c/= :: forall n. Eq n => TooLarge n -> TooLarge n -> Bool
== :: TooLarge n -> TooLarge n -> Bool
$c== :: forall n. Eq n => TooLarge n -> TooLarge n -> Bool
Eq, Int -> TooLarge n -> ShowS
forall n. Show n => Int -> TooLarge n -> ShowS
forall n. Show n => [TooLarge n] -> ShowS
forall n. Show n => TooLarge n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TooLarge n] -> ShowS
$cshowList :: forall n. Show n => [TooLarge n] -> ShowS
show :: TooLarge n -> String
$cshow :: forall n. Show n => TooLarge n -> String
showsPrec :: Int -> TooLarge n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> TooLarge n -> ShowS
Show)

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

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

instance EncCBOR n => EncCBOR (TooLarge n) where
  encCBOR :: TooLarge n -> Encoding
encCBOR TooLarge {n
tlActual :: n
tlActual :: forall n. TooLarge n -> n
tlActual, n
tlMaxBound :: n
tlMaxBound :: forall n. TooLarge n -> n
tlMaxBound} =
    Word -> Encoding
encodeListLen Word
2
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR n
tlActual
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR n
tlMaxBound

instance DecCBOR n => DecCBOR (TooLarge n) where
  decCBOR :: forall s. Decoder s (TooLarge n)
decCBOR = do
    forall s. Text -> Int -> Decoder s ()
enforceSize Text
"TooLarge" Int
2
    forall n. n -> n -> TooLarge n
TooLarge 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

newtype Adopted = Adopted ProtocolVersion
  deriving (Adopted -> Adopted -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Adopted -> Adopted -> Bool
$c/= :: Adopted -> Adopted -> Bool
== :: Adopted -> Adopted -> Bool
$c== :: Adopted -> Adopted -> Bool
Eq, Int -> Adopted -> ShowS
[Adopted] -> ShowS
Adopted -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Adopted] -> ShowS
$cshowList :: [Adopted] -> ShowS
show :: Adopted -> String
$cshow :: Adopted -> String
showsPrec :: Int -> Adopted -> ShowS
$cshowsPrec :: Int -> Adopted -> ShowS
Show)
  deriving newtype (Typeable Adopted
Adopted -> Encoding
(forall t. EncCBOR t => Proxy t -> Size) -> Proxy [Adopted] -> Size
(forall t. EncCBOR t => Proxy t -> Size) -> Proxy Adopted -> Size
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> EncCBOR a
encodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy [Adopted] -> Size
$cencodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy [Adopted] -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy Adopted -> Size
$cencodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy Adopted -> Size
encCBOR :: Adopted -> Encoding
$cencCBOR :: Adopted -> Encoding
EncCBOR, Typeable Adopted
Proxy Adopted -> Text
forall s. Decoder s Adopted
forall a.
Typeable a
-> (forall s. Decoder s a)
-> (forall s. Proxy a -> Decoder s ())
-> (Proxy a -> Text)
-> DecCBOR a
forall s. Proxy Adopted -> Decoder s ()
label :: Proxy Adopted -> Text
$clabel :: Proxy Adopted -> Text
dropCBOR :: forall s. Proxy Adopted -> Decoder s ()
$cdropCBOR :: forall s. Proxy Adopted -> Decoder s ()
decCBOR :: forall s. Decoder s Adopted
$cdecCBOR :: forall s. Decoder s Adopted
DecCBOR)

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

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

-- | Register an update proposal after verifying its signature and validating
--   its contents. This corresponds to the @UPREG@ rules in the spec.
registerProposal ::
  MonadError Error m =>
  Environment ->
  State ->
  AProposal ByteString ->
  m State
registerProposal :: forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> AProposal ByteString -> m State
registerProposal Environment
env State
rs AProposal ByteString
proposal = do
  -- Check that the proposer is delegated to by a genesis key
  KeyHash -> Map -> Bool
Delegation.memberR KeyHash
proposerId Map
delegationMap
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` KeyHash -> Error
InvalidProposer KeyHash
proposerId

  -- Verify the proposal signature
  forall t.
Decoded t =>
Annotated ProtocolMagicId ByteString
-> SignTag
-> VerificationKey
-> t
-> Signature (BaseType t)
-> Bool
verifySignatureDecoded
    Annotated ProtocolMagicId ByteString
protocolMagic
    SignTag
SignUSProposal
    VerificationKey
issuer
    (Annotated ProposalBody ByteString
-> Annotated ProposalBody ByteString
recoverProposalSignedBytes Annotated ProposalBody ByteString
aBody)
    Signature ProposalBody
signature
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` Error
InvalidSignature

  -- Check that the proposal is valid
  forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> AProposal ByteString -> m State
registerProposalComponents
    Environment
env
    State
rs
    AProposal ByteString
proposal
  where
    AProposal {Annotated ProposalBody ByteString
$sel:aBody:AProposal :: forall a. AProposal a -> Annotated ProposalBody a
aBody :: Annotated ProposalBody ByteString
aBody, VerificationKey
$sel:issuer:AProposal :: forall a. AProposal a -> VerificationKey
issuer :: VerificationKey
issuer, Signature ProposalBody
$sel:signature:AProposal :: forall a. AProposal a -> Signature ProposalBody
signature :: Signature ProposalBody
signature} = AProposal ByteString
proposal

    proposerId :: KeyHash
proposerId = VerificationKey -> KeyHash
hashKey VerificationKey
issuer

    Environment
      { Annotated ProtocolMagicId ByteString
protocolMagic :: Annotated ProtocolMagicId ByteString
protocolMagic :: Environment -> Annotated ProtocolMagicId ByteString
protocolMagic
      , Map
delegationMap :: Map
delegationMap :: Environment -> Map
delegationMap
      } = Environment
env

-- | Register the individual components of an update proposal
--
--   The proposal may contain a protocol update, a software update, or both.
--   This corresponds to the `UPV` rules in the spec.
registerProposalComponents ::
  MonadError Error m =>
  Environment ->
  State ->
  AProposal ByteString ->
  m State
registerProposalComponents :: forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> AProposal ByteString -> m State
registerProposalComponents Environment
env State
rs AProposal ByteString
proposal = do
  (Bool
protocolVersionChanged Bool -> Bool -> Bool
|| Bool
softwareVersionChanged Bool -> Bool -> Bool
|| Bool
nullUpdateExemptions)
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` Error
NullUpdateProposal

  -- Register protocol update if we have one
  ProtocolUpdateProposals
registeredPUPs' <-
    if Bool
protocolVersionChanged
      then forall (m :: * -> *).
MonadError Error m =>
ProtocolVersion
-> ProtocolParameters
-> ProtocolUpdateProposals
-> AProposal ByteString
-> m ProtocolUpdateProposals
registerProtocolUpdate ProtocolVersion
adoptedPV ProtocolParameters
adoptedPP ProtocolUpdateProposals
registeredPUPs AProposal ByteString
proposal
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure ProtocolUpdateProposals
registeredPUPs

  -- Register software update if we have one
  SoftwareUpdateProposals
registeredSUPs' <-
    if Bool
softwareVersionChanged
      then forall (m :: * -> *).
MonadError Error m =>
ApplicationVersions
-> SoftwareUpdateProposals
-> AProposal ByteString
-> m SoftwareUpdateProposals
registerSoftwareUpdate ApplicationVersions
appVersions SoftwareUpdateProposals
registeredSUPs AProposal ByteString
proposal
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure SoftwareUpdateProposals
registeredSUPs

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ProtocolUpdateProposals -> SoftwareUpdateProposals -> State
State ProtocolUpdateProposals
registeredPUPs' SoftwareUpdateProposals
registeredSUPs'
  where
    ProposalBody
      { ProtocolVersion
protocolVersion :: ProtocolVersion
$sel:protocolVersion:ProposalBody :: ProposalBody -> ProtocolVersion
protocolVersion
      , $sel:protocolParametersUpdate:ProposalBody :: ProposalBody -> ProtocolParametersUpdate
protocolParametersUpdate = ProtocolParametersUpdate
ppu
      , SoftwareVersion
softwareVersion :: SoftwareVersion
$sel:softwareVersion:ProposalBody :: ProposalBody -> SoftwareVersion
softwareVersion
      } = forall a. AProposal a -> ProposalBody
Proposal.body AProposal ByteString
proposal

    SoftwareVersion ApplicationName
appName NumSoftwareVersion
appVersion = SoftwareVersion
softwareVersion

    softwareVersionChanged :: Bool
softwareVersionChanged =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((forall a. Eq a => a -> a -> Bool
/= NumSoftwareVersion
appVersion) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ApplicationVersion -> NumSoftwareVersion
avNumSoftwareVersion)
        forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ApplicationName
appName ApplicationVersions
appVersions

    protocolVersionChanged :: Bool
protocolVersionChanged =
      Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ProtocolVersion
protocolVersion forall a. Eq a => a -> a -> Bool
== ProtocolVersion
adoptedPV Bool -> Bool -> Bool
&& ProtocolParametersUpdate
-> ProtocolParameters -> ProtocolParameters
PPU.apply ProtocolParametersUpdate
ppu ProtocolParameters
adoptedPP forall a. Eq a => a -> a -> Bool
== ProtocolParameters
adoptedPP

    Environment
      { Annotated ProtocolMagicId ByteString
protocolMagic :: Annotated ProtocolMagicId ByteString
protocolMagic :: Environment -> Annotated ProtocolMagicId ByteString
protocolMagic
      , SlotNumber
currentSlot :: SlotNumber
currentSlot :: Environment -> SlotNumber
currentSlot
      , adoptedProtocolVersion :: Environment -> ProtocolVersion
adoptedProtocolVersion = ProtocolVersion
adoptedPV
      , adoptedProtocolParameters :: Environment -> ProtocolParameters
adoptedProtocolParameters = ProtocolParameters
adoptedPP
      , ApplicationVersions
appVersions :: ApplicationVersions
appVersions :: Environment -> ApplicationVersions
appVersions
      } = Environment
env

    State ProtocolUpdateProposals
registeredPUPs SoftwareUpdateProposals
registeredSUPs = State
rs

    -- A "null" update proposal is one that neither increase the protocol
    -- version nor the software version. Such update proposals are invalid
    -- according to the Byron specification. However in the cardano-sl code
    -- they are accepted onto the chain but without any state change.
    --
    -- We cannot follow the legacy cardano-sl interpretation of accepting null
    -- update onto the chain with no effect because it opens the door to DoS
    -- attacks by replaying null update proposals.
    --
    -- For further details see:
    --
    -- https://github.com/intersectmbo/cardano-ledger/issues/759
    -- https://github.com/intersectmbo/cardano-ledger/pull/766
    --
    -- The existing staging network (protocol magic 633343913) does have existing
    -- null update proposals however: one in epoch 44 (slot number 969188) and
    -- one in epoch 88 (slot number 1915231). We could delete the staging network
    -- blockchain and start from scratch, however it is extremely useful for
    -- testing to have a realistic chain that is as long as the mainnet chain,
    -- and indeed that has a large prefix that was created by the legacy
    -- cardano-sl codebase. Therefore we allow for these specific excemptions on
    -- this non-public testing network.
    --
    nullUpdateExemptions :: Bool
nullUpdateExemptions =
      forall b a. Annotated b a -> b
unAnnotated Annotated ProtocolMagicId ByteString
protocolMagic
        forall a. Eq a => a -> a -> Bool
== NumSoftwareVersion -> ProtocolMagicId
ProtocolMagicId NumSoftwareVersion
633343913 -- staging
        Bool -> Bool -> Bool
&& ( SlotNumber
currentSlot
              forall a. Eq a => a -> a -> Bool
== Word64 -> SlotNumber
SlotNumber Word64
969188 -- in epoch 44
              Bool -> Bool -> Bool
|| SlotNumber
currentSlot
              forall a. Eq a => a -> a -> Bool
== Word64 -> SlotNumber
SlotNumber Word64
1915231 -- in epoch 88
           )

-- | Validate a protocol update
--
--   We check that:
--
--   1) The protocol update hasn't already been registered
--   2) The protocol version is a valid next version
--   3) The new 'ProtocolParameters' represent a valid update
--
--   This corresponds to the `UPPVV` rule in the spec.
registerProtocolUpdate ::
  MonadError Error m =>
  ProtocolVersion ->
  ProtocolParameters ->
  ProtocolUpdateProposals ->
  AProposal ByteString ->
  m ProtocolUpdateProposals
registerProtocolUpdate :: forall (m :: * -> *).
MonadError Error m =>
ProtocolVersion
-> ProtocolParameters
-> ProtocolUpdateProposals
-> AProposal ByteString
-> m ProtocolUpdateProposals
registerProtocolUpdate ProtocolVersion
adoptedPV ProtocolParameters
adoptedPP ProtocolUpdateProposals
registeredPUPs AProposal ByteString
proposal = do
  -- Check that this protocol version isn't already registered
  forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ((forall a. Eq a => a -> a -> Bool
== ProtocolVersion
newPV) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ProtocolUpdateProposal -> ProtocolVersion
pupProtocolVersion) ProtocolUpdateProposals
registeredPUPs)
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` ProtocolVersion -> Error
DuplicateProtocolVersion ProtocolVersion
newPV

  -- Check that this protocol version is a valid next version
  ProtocolVersion -> ProtocolVersion -> Bool
pvCanFollow ProtocolVersion
newPV ProtocolVersion
adoptedPV
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` ProtocolVersion -> Adopted -> Error
InvalidProtocolVersion ProtocolVersion
newPV (ProtocolVersion -> Adopted
Adopted ProtocolVersion
adoptedPV)

  forall (m :: * -> *).
MonadError Error m =>
ProtocolParameters
-> ProtocolParameters -> AProposal ByteString -> m ()
canUpdate ProtocolParameters
adoptedPP ProtocolParameters
newPP AProposal ByteString
proposal

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert
      (AProposal ByteString -> UpId
recoverUpId AProposal ByteString
proposal)
      (ProtocolVersion -> ProtocolParameters -> ProtocolUpdateProposal
ProtocolUpdateProposal ProtocolVersion
newPV ProtocolParameters
newPP)
      ProtocolUpdateProposals
registeredPUPs
  where
    ProposalBody {$sel:protocolVersion:ProposalBody :: ProposalBody -> ProtocolVersion
protocolVersion = ProtocolVersion
newPV, ProtocolParametersUpdate
protocolParametersUpdate :: ProtocolParametersUpdate
$sel:protocolParametersUpdate:ProposalBody :: ProposalBody -> ProtocolParametersUpdate
protocolParametersUpdate} =
      forall a. AProposal a -> ProposalBody
Proposal.body AProposal ByteString
proposal
    newPP :: ProtocolParameters
newPP = ProtocolParametersUpdate
-> ProtocolParameters -> ProtocolParameters
PPU.apply ProtocolParametersUpdate
protocolParametersUpdate ProtocolParameters
adoptedPP

-- | Check that the new 'ProtocolVersion' is a valid next version
pvCanFollow :: ProtocolVersion -> ProtocolVersion -> Bool
pvCanFollow :: ProtocolVersion -> ProtocolVersion -> Bool
pvCanFollow ProtocolVersion
newPV ProtocolVersion
adoptedPV = ProtocolVersion
adoptedPV forall a. Ord a => a -> a -> Bool
< ProtocolVersion
newPV Bool -> Bool -> Bool
&& Bool
isNextVersion
  where
    ProtocolVersion Word16
newMajor Word16
newMinor Word8
_ = ProtocolVersion
newPV
    ProtocolVersion Word16
adoptedMajor Word16
adoptedMinor Word8
_ = ProtocolVersion
adoptedPV
    isNextVersion :: Bool
isNextVersion = case Word16
newMajor forall a. Num a => a -> a -> a
- Word16
adoptedMajor of
      Word16
0 -> Word16
newMinor forall a. Eq a => a -> a -> Bool
== Word16
adoptedMinor forall a. Num a => a -> a -> a
+ Word16
1
      Word16
1 -> Word16
newMinor forall a. Eq a => a -> a -> Bool
== Word16
0
      Word16
_ -> Bool
False

-- | Check that the new 'ProtocolParameters' represent a valid update
--
--   This is where we enforce constraints on how the 'ProtocolParameters'
--   change.
canUpdate ::
  MonadError Error m =>
  ProtocolParameters ->
  ProtocolParameters ->
  AProposal ByteString ->
  m ()
canUpdate :: forall (m :: * -> *).
MonadError Error m =>
ProtocolParameters
-> ProtocolParameters -> AProposal ByteString -> m ()
canUpdate ProtocolParameters
adoptedPP ProtocolParameters
proposedPP AProposal ByteString
proposal = do
  -- Check that the proposal size is less than the maximum
  (Natural
proposalSize forall a. Ord a => a -> a -> Bool
<= Natural
maxProposalSize)
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` TooLarge Natural -> Error
ProposalTooLarge
      (forall n. n -> n -> TooLarge n
TooLarge Natural
maxProposalSize Natural
proposalSize)

  -- Check that the new maximum block size is no more than twice the current one
  (Natural
newMaxBlockSize forall a. Ord a => a -> a -> Bool
<= Natural
2 forall a. Num a => a -> a -> a
* Natural
adoptedMaxBlockSize)
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` TooLarge Natural -> Error
MaxBlockSizeTooLarge
      (forall n. n -> n -> TooLarge n
TooLarge Natural
adoptedMaxBlockSize Natural
newMaxBlockSize)

  -- Check that the new max transaction size is less than the new max block size
  (Natural
newMaxTxSize forall a. Ord a => a -> a -> Bool
< Natural
newMaxBlockSize)
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` TooLarge Natural -> Error
MaxTxSizeTooLarge
      (forall n. n -> n -> TooLarge n
TooLarge Natural
newMaxBlockSize Natural
newMaxTxSize)

  -- Check that the new script version is either the same or incremented
  (Word16
0 forall a. Ord a => a -> a -> Bool
<= Word16
scriptVersionDiff Bool -> Bool -> Bool
&& Word16
scriptVersionDiff forall a. Ord a => a -> a -> Bool
<= Word16
1)
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` Word16 -> Word16 -> Error
InvalidScriptVersion
      Word16
adoptedScriptVersion
      Word16
newScriptVersion
  where
    proposalSize :: Natural
    proposalSize :: Natural
proposalSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Int
BS.length forall a b. (a -> b) -> a -> b
$ forall a. AProposal a -> a
Proposal.annotation AProposal ByteString
proposal
    maxProposalSize :: Natural
maxProposalSize = ProtocolParameters -> Natural
ppMaxProposalSize ProtocolParameters
adoptedPP

    adoptedMaxBlockSize :: Natural
adoptedMaxBlockSize = ProtocolParameters -> Natural
ppMaxBlockSize ProtocolParameters
adoptedPP
    newMaxBlockSize :: Natural
newMaxBlockSize = ProtocolParameters -> Natural
ppMaxBlockSize ProtocolParameters
proposedPP

    newMaxTxSize :: Natural
newMaxTxSize = ProtocolParameters -> Natural
ppMaxTxSize ProtocolParameters
proposedPP

    adoptedScriptVersion :: Word16
adoptedScriptVersion = ProtocolParameters -> Word16
ppScriptVersion ProtocolParameters
adoptedPP
    newScriptVersion :: Word16
newScriptVersion = ProtocolParameters -> Word16
ppScriptVersion ProtocolParameters
proposedPP
    scriptVersionDiff :: Word16
scriptVersionDiff = Word16
newScriptVersion forall a. Num a => a -> a -> a
- Word16
adoptedScriptVersion

-- | Check that a new 'SoftwareVersion' is valid
--
--   We check that:
--
--   1) The 'SoftwareVersion' hasn't already been registered
--   2) The 'SoftwareVersion' is valid according to static checks
--   3) The new 'SoftwareVersion' is a valid next version
--
--   This corresponds to the `UPSVV` rule in the spec.
registerSoftwareUpdate ::
  MonadError Error m =>
  ApplicationVersions ->
  SoftwareUpdateProposals ->
  AProposal ByteString ->
  m SoftwareUpdateProposals
registerSoftwareUpdate :: forall (m :: * -> *).
MonadError Error m =>
ApplicationVersions
-> SoftwareUpdateProposals
-> AProposal ByteString
-> m SoftwareUpdateProposals
registerSoftwareUpdate ApplicationVersions
appVersions SoftwareUpdateProposals
registeredSUPs AProposal ByteString
proposal = do
  -- Check that the 'SystemTag's in the metadata are valid
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *).
MonadError SystemTagError m =>
SystemTag -> m ()
checkSystemTag (forall k a. Map k a -> [k]
M.keys Metadata
metadata) forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` SystemTagError -> Error
SystemTagError

  -- Check that this software version isn't already registered
  forall (t :: * -> *) a. Foldable t => t a -> Bool
null
    ( forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter
        ((forall a. Eq a => a -> a -> Bool
== SoftwareVersion -> ApplicationName
svAppName SoftwareVersion
softwareVersion) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. SoftwareVersion -> ApplicationName
svAppName forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. SoftwareUpdateProposal -> SoftwareVersion
supSoftwareVersion)
        SoftwareUpdateProposals
registeredSUPs
    )
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` SoftwareVersion -> Error
DuplicateSoftwareVersion SoftwareVersion
softwareVersion

  -- Check that the software version is valid
  forall (m :: * -> *).
MonadError SoftwareVersionError m =>
SoftwareVersion -> m ()
checkSoftwareVersion SoftwareVersion
softwareVersion forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` SoftwareVersionError -> Error
SoftwareVersionError

  -- Check that this software version is a valid next version
  ApplicationVersions -> SoftwareVersion -> Bool
svCanFollow ApplicationVersions
appVersions SoftwareVersion
softwareVersion
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` ApplicationVersions -> SoftwareVersion -> Error
InvalidSoftwareVersion ApplicationVersions
appVersions SoftwareVersion
softwareVersion

  -- Add to the list of registered software update proposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert
      (AProposal ByteString -> UpId
recoverUpId AProposal ByteString
proposal)
      (SoftwareVersion -> Metadata -> SoftwareUpdateProposal
SoftwareUpdateProposal SoftwareVersion
softwareVersion Metadata
metadata)
      SoftwareUpdateProposals
registeredSUPs
  where
    ProposalBody {SoftwareVersion
softwareVersion :: SoftwareVersion
$sel:softwareVersion:ProposalBody :: ProposalBody -> SoftwareVersion
softwareVersion, Metadata
$sel:metadata:ProposalBody :: ProposalBody -> Metadata
metadata :: Metadata
metadata} = forall a. AProposal a -> ProposalBody
Proposal.body AProposal ByteString
proposal

-- | Check that a new 'SoftwareVersion' is a valid next version
--
--   The new version is valid for a given application if it is exactly one
--   more than the current version
svCanFollow :: ApplicationVersions -> SoftwareVersion -> Bool
svCanFollow :: ApplicationVersions -> SoftwareVersion -> Bool
svCanFollow ApplicationVersions
avs (SoftwareVersion ApplicationName
appName NumSoftwareVersion
appVersion) =
  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ApplicationName
appName ApplicationVersions
avs of
    -- For new apps, the version must start at 0 or 1.
    Maybe ApplicationVersion
Nothing -> NumSoftwareVersion
appVersion forall a. Eq a => a -> a -> Bool
== NumSoftwareVersion
0 Bool -> Bool -> Bool
|| NumSoftwareVersion
appVersion forall a. Eq a => a -> a -> Bool
== NumSoftwareVersion
1
    -- For existing apps, it must be exactly one more than the current version
    Just (ApplicationVersion NumSoftwareVersion
currentAppVersion SlotNumber
_ Metadata
_) -> NumSoftwareVersion
appVersion forall a. Eq a => a -> a -> Bool
== NumSoftwareVersion
currentAppVersion forall a. Num a => a -> a -> a
+ NumSoftwareVersion
1