diff --git a/core/cardano-sl-core.cabal b/core/cardano-sl-core.cabal index 9ccf77e6948..09e6dcd100c 100644 --- a/core/cardano-sl-core.cabal +++ b/core/cardano-sl-core.cabal @@ -25,7 +25,6 @@ library Pos.Aeson.Genesis Pos.Binary.Core - Pos.Binary.Merkle Pos.Core Pos.Core.Chrono @@ -61,15 +60,8 @@ library other-modules: -- Binary Pos.Binary.Core.Address - Pos.Binary.Core.Block - Pos.Binary.Core.Blockchain - Pos.Binary.Core.Common - Pos.Binary.Core.Delegation - Pos.Binary.Core.Fee Pos.Binary.Core.Script - Pos.Binary.Core.Slotting Pos.Binary.Core.Ssc - Pos.Binary.Core.Txp Pos.Binary.Core.Update -- Block @@ -230,6 +222,7 @@ library MultiParamTypeClasses FunctionalDependencies DefaultSignatures + InstanceSigs NoImplicitPrelude OverloadedStrings RankNTypes diff --git a/core/src/Pos/Binary/Core.hs b/core/src/Pos/Binary/Core.hs index c07306f7016..f5c980baf42 100644 --- a/core/src/Pos/Binary/Core.hs +++ b/core/src/Pos/Binary/Core.hs @@ -3,26 +3,8 @@ module Pos.Binary.Core ( module Pos.Binary.Core.Address - , module Pos.Binary.Core.Block - , module Pos.Binary.Core.Blockchain - , module Pos.Binary.Core.Common - , module Pos.Binary.Core.Delegation - , module Pos.Binary.Core.Fee , module Pos.Binary.Core.Script - , module Pos.Binary.Core.Slotting - , module Pos.Binary.Core.Ssc - , module Pos.Binary.Core.Txp - , module Pos.Binary.Core.Update ) where import Pos.Binary.Core.Address -import Pos.Binary.Core.Block -import Pos.Binary.Core.Blockchain -import Pos.Binary.Core.Common () -import Pos.Binary.Core.Delegation () -import Pos.Binary.Core.Fee () -import Pos.Binary.Core.Script () -import Pos.Binary.Core.Slotting -import Pos.Binary.Core.Ssc -import Pos.Binary.Core.Txp -import Pos.Binary.Core.Update \ No newline at end of file +import Pos.Binary.Core.Script () \ No newline at end of file diff --git a/core/src/Pos/Binary/Core/Block.hs b/core/src/Pos/Binary/Core/Block.hs deleted file mode 100644 index 0fc5f64e2c1..00000000000 --- a/core/src/Pos/Binary/Core/Block.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Serialization of core types from 'Pos.Core.Block'. - -module Pos.Binary.Core.Block - ( - ) where - -import Universum - -import Pos.Binary.Class (Bi (..), Cons (..), Field (..), deriveSimpleBi, encodeListLen, - encodeListLen, enforceSize) -import Pos.Binary.Core.Delegation () -import Pos.Binary.Core.Slotting () -import Pos.Binary.Core.Ssc () -import Pos.Binary.Core.Txp () -import Pos.Binary.Core.Update () -import qualified Pos.Core.Block.Genesis.Types as BC -import qualified Pos.Core.Block.Main.Types as BC -import qualified Pos.Core.Block.Union.Types as BC -import Pos.Core.Update (BlockVersion, SoftwareVersion) -import Pos.Crypto (Hash) -import Pos.Util.Util (cborError) - ----------------------------------------------------------------------------- --- MainBlock ----------------------------------------------------------------------------- - -instance Bi BC.MainProof where - encode bc = encodeListLen 4 - <> encode (BC.mpTxProof bc) - <> encode (BC.mpMpcProof bc) - <> encode (BC.mpProxySKsProof bc) - <> encode (BC.mpUpdateProof bc) - decode = do - enforceSize "Core.BodyProof BC.MainBlockChain" 4 - BC.MainProof <$> decode <*> - decode <*> - decode <*> - decode - -instance Bi BC.BlockSignature where - encode input = case input of - BC.BlockSignature sig -> encodeListLen 2 <> encode (0 :: Word8) <> encode sig - BC.BlockPSignatureLight pxy -> encodeListLen 2 <> encode (1 :: Word8) <> encode pxy - BC.BlockPSignatureHeavy pxy -> encodeListLen 2 <> encode (2 :: Word8) <> encode pxy - decode = do - enforceSize "BlockSignature" 2 - tag <- decode @Word8 - case tag of - 0 -> BC.BlockSignature <$> decode - 1 -> BC.BlockPSignatureLight <$> decode - 2 -> BC.BlockPSignatureHeavy <$> decode - _ -> cborError $ "decode@BlockSignature: unknown tag: " <> show tag - -instance Bi BC.MainConsensusData where - encode cd = encodeListLen 4 - <> encode (BC._mcdSlot cd) - <> encode (BC._mcdLeaderKey cd) - <> encode (BC._mcdDifficulty cd) - <> encode (BC._mcdSignature cd) - decode = do - enforceSize "BC.ConsensusData BC.MainBlockchain)" 4 - BC.MainConsensusData <$> decode <*> - decode <*> - decode <*> - decode - -instance Bi BC.MainBody where - encode bc = encodeListLen 4 - <> encode (BC._mbTxPayload bc) - <> encode (BC._mbSscPayload bc) - <> encode (BC._mbDlgPayload bc) - <> encode (BC._mbUpdatePayload bc) - decode = do - enforceSize "BC.Body BC.MainBlockchain" 4 - BC.MainBody <$> decode <*> - decode <*> - decode <*> - decode - -deriveSimpleBi ''BC.MainExtraHeaderData [ - Cons 'BC.MainExtraHeaderData [ - Field [| BC._mehBlockVersion :: BlockVersion |], - Field [| BC._mehSoftwareVersion :: SoftwareVersion |], - Field [| BC._mehAttributes :: BC.BlockHeaderAttributes |], - Field [| BC._mehEBDataProof :: Hash BC.MainExtraBodyData |] - ]] - -deriveSimpleBi ''BC.MainExtraBodyData [ - Cons 'BC.MainExtraBodyData [ - Field [| BC._mebAttributes :: BC.BlockBodyAttributes |] - ]] - -instance Bi BC.MainToSign where - encode mts = encodeListLen 5 - <> encode (BC._msHeaderHash mts) - <> encode (BC._msBodyProof mts) - <> encode (BC._msSlot mts) - <> encode (BC._msChainDiff mts) - <> encode (BC._msExtraHeader mts) - decode = do - enforceSize "BC.MainToSign" 5 - BC.MainToSign <$> decode <*> - decode <*> - decode <*> - decode <*> - decode - --- ---------------------------------------------------------------------------- --- -- GenesisBlock --- ---------------------------------------------------------------------------- - -deriveSimpleBi ''BC.GenesisExtraHeaderData [ - Cons 'BC.GenesisExtraHeaderData [ - Field [| BC._gehAttributes :: BC.GenesisHeaderAttributes |] - ]] - -deriveSimpleBi ''BC.GenesisExtraBodyData [ - Cons 'BC.GenesisExtraBodyData [ - Field [| BC._gebAttributes :: BC.GenesisBodyAttributes |] - ]] - -instance Bi BC.GenesisProof where - encode (BC.GenesisProof h) = encode h - decode = BC.GenesisProof <$> decode - -instance Bi BC.GenesisConsensusData where - encode bc = encodeListLen 2 - <> encode (BC._gcdEpoch bc) - <> encode (BC._gcdDifficulty bc) - decode = do - enforceSize "BC.ConsensusData BC.GenesisBlockchain" 2 - BC.GenesisConsensusData <$> decode <*> decode - -instance Bi BC.GenesisBody where - encode = encode . BC._gbLeaders - decode = BC.GenesisBody <$> decode diff --git a/core/src/Pos/Binary/Core/Blockchain.hs b/core/src/Pos/Binary/Core/Blockchain.hs deleted file mode 100644 index a30f30db885..00000000000 --- a/core/src/Pos/Binary/Core/Blockchain.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Binary serialization of core block types. - -module Pos.Binary.Core.Blockchain - ( - ) where - -import Codec.CBOR.Decoding (decodeWordCanonical) -import Codec.CBOR.Encoding (encodeWord) -import Universum - -import Pos.Binary.Class (Bi (..), decodeListLenCanonicalOf, encodeListLen, enforceSize) -import Pos.Binary.Core.Block () -import Pos.Binary.Core.Common () -import qualified Pos.Core.Block.Blockchain as T -import Pos.Core.Block.Union.Types (BlockHeader (..)) -import Pos.Crypto.Configuration (ProtocolMagic (..)) -import Pos.Util.Util (cborError) - -instance ( Typeable b - , Bi (T.BHeaderHash b) - , Bi (T.BodyProof b) - , Bi (T.ConsensusData b) - , Bi (T.ExtraHeaderData b) - ) => - Bi (T.GenericBlockHeader b) where - encode bh = encodeListLen 5 - <> encode (getProtocolMagic (T._gbhProtocolMagic bh)) - <> encode (T._gbhPrevBlock bh) - <> encode (T._gbhBodyProof bh) - <> encode (T._gbhConsensus bh) - <> encode (T._gbhExtra bh) - decode = do - enforceSize "GenericBlockHeader b" 5 - _gbhProtocolMagic <- ProtocolMagic <$> decode - _gbhPrevBlock <- decode - _gbhBodyProof <- decode - _gbhConsensus <- decode - _gbhExtra <- decode - pure T.UnsafeGenericBlockHeader {..} - -instance ( Typeable b - , Bi (T.BHeaderHash b) - , Bi (T.BodyProof b) - , Bi (T.ConsensusData b) - , Bi (T.ExtraHeaderData b) - , Bi (T.Body b) - , Bi (T.ExtraBodyData b) - ) => - Bi (T.GenericBlock b) where - encode gb = encodeListLen 3 - <> encode (T._gbHeader gb) - <> encode (T._gbBody gb) - <> encode (T._gbExtra gb) - decode = do - enforceSize "GenericBlock" 3 - _gbHeader <- decode - _gbBody <- decode - _gbExtra <- decode - pure T.UnsafeGenericBlock {..} - ----------------------------------------------------------------------------- --- BlockHeader ----------------------------------------------------------------------------- - -instance Bi BlockHeader where - encode x = encodeListLen 2 <> encodeWord tag <> body - where - (tag, body) = case x of - BlockHeaderGenesis bh -> (0, encode bh) - BlockHeaderMain bh -> (1, encode bh) - - decode = do - decodeListLenCanonicalOf 2 - t <- decodeWordCanonical - case t of - 0 -> BlockHeaderGenesis <$!> decode - 1 -> BlockHeaderMain <$!> decode - _ -> cborError $ "decode@BlockHeader: unknown tag " <> pretty t diff --git a/core/src/Pos/Binary/Core/Common.hs b/core/src/Pos/Binary/Core/Common.hs deleted file mode 100644 index 382449e6d70..00000000000 --- a/core/src/Pos/Binary/Core/Common.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Pos.Binary.Core.Common () where - -import Universum - -import Pos.Binary.Class (Bi (..), Cons (..), Field (..), deriveSimpleBi) -import Pos.Core.Common (Coin (..), unsafeGetCoin) -import qualified Pos.Core.Common as T -import qualified Pos.Data.Attributes as A -import Pos.Util.Orphans () - --- kind of boilerplate, but anyway that's what it was made for -- --- verbosity and clarity - -instance Bi (A.Attributes ()) where - encode = A.encodeAttributes [] - decode = A.decodeAttributes () $ \_ _ _ -> pure Nothing - -instance Bi T.BlockCount where - encode = encode . T.getBlockCount - decode = T.BlockCount <$> decode - -deriveSimpleBi ''T.SharedSeed [ - Cons 'T.SharedSeed [ - Field [| T.getSharedSeed :: ByteString |] - ]] - -deriveSimpleBi ''T.ChainDifficulty [ - Cons 'T.ChainDifficulty [ - Field [| T.getChainDifficulty :: T.BlockCount |] - ]] - ----------------------------------------------------------------------------- --- Coin ----------------------------------------------------------------------------- - --- number of total coins is 45*10^9 * 10^6 --- --- Input | Bits to represent | --- ------------------------------| ----------------- | --- 0-9 | 8 bits | --- 0-99 | 16 bits | --- 0-999 | 24 bits | --- 0-9999 | 24 bits | --- 0-99999 | 40 bits | --- 0-999999 | 40 bits | --- 45*10^15 | 72 bits | --- 45*10^9 | 72 bits | --- 45*10^9 * 10^6 (maxbound) | 72 bits | --- maxbound - 1 | 72 bits | - -instance Bi Coin where - encode = encode . unsafeGetCoin - decode = Coin <$> decode diff --git a/core/src/Pos/Binary/Core/Delegation.hs b/core/src/Pos/Binary/Core/Delegation.hs deleted file mode 100644 index b32d4015ecf..00000000000 --- a/core/src/Pos/Binary/Core/Delegation.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Delegation types serialization. - -module Pos.Binary.Core.Delegation () where - -import Universum - -import Pos.Binary.Class (Bi (..)) -import Pos.Binary.Core.Slotting () -import Pos.Core.Delegation (DlgPayload (..), HeavyDlgIndex (..), LightDlgIndices (..)) - -instance Bi HeavyDlgIndex where - encode = encode . getHeavyDlgIndex - decode = HeavyDlgIndex <$> decode - -instance Bi LightDlgIndices where - encode = encode . getLightDlgIndices - decode = LightDlgIndices <$> decode - -instance Bi DlgPayload where - encode = encode . getDlgPayload - decode = UnsafeDlgPayload <$> decode diff --git a/core/src/Pos/Binary/Core/Fee.hs b/core/src/Pos/Binary/Core/Fee.hs deleted file mode 100644 index e39af72051a..00000000000 --- a/core/src/Pos/Binary/Core/Fee.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Binary instances for transaction fee data. - -module Pos.Binary.Core.Fee () where - -import Universum - -import qualified Data.ByteString.Lazy as LBS -import Data.Fixed (Nano) - -import Pos.Binary.Class (Bi (..), decode, decodeKnownCborDataItem, - decodeUnknownCborDataItem, encode, encodeKnownCborDataItem, - encodeListLen, encodeUnknownCborDataItem, enforceSize) -import Pos.Core.Common (Coeff (..), TxFeePolicy (..), TxSizeLinear (..)) - -instance Bi Coeff where - encode (Coeff n) = encode n - decode = Coeff <$> decode @Nano - -instance Bi TxSizeLinear where - encode (TxSizeLinear a b) = encodeListLen 2 <> encode a <> encode b - decode = do - enforceSize "TxSizeLinear" 2 - !a <- decode @Coeff - !b <- decode @Coeff - return $ TxSizeLinear a b - -instance Bi TxFeePolicy where - encode policy = case policy of - TxFeePolicyTxSizeLinear txSizeLinear -> - encodeListLen 2 <> encode (0 :: Word8) - <> encodeKnownCborDataItem txSizeLinear - TxFeePolicyUnknown word8 bs -> - encodeListLen 2 <> encode word8 - <> encodeUnknownCborDataItem (LBS.fromStrict bs) - decode = do - enforceSize "TxFeePolicy" 2 - tag <- decode @Word8 - case tag of - 0 -> TxFeePolicyTxSizeLinear <$> decodeKnownCborDataItem - _ -> TxFeePolicyUnknown tag <$> decodeUnknownCborDataItem diff --git a/core/src/Pos/Binary/Core/Slotting.hs b/core/src/Pos/Binary/Core/Slotting.hs deleted file mode 100644 index a87cc6da4c0..00000000000 --- a/core/src/Pos/Binary/Core/Slotting.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Binary serialization of slotting types. - -module Pos.Binary.Core.Slotting - ( - ) where - -import Universum - -import Pos.Binary.Class (Bi (..), Cons (..), Field (..), deriveSimpleBi) -import qualified Pos.Core.Slotting as T - -instance Bi T.Timestamp where - encode (T.Timestamp ms) = encode . toInteger $ ms - decode = T.Timestamp . fromIntegral <$> decode @Integer - -instance Bi T.TimeDiff where - encode = encode . toInteger - decode = fromInteger <$> decode - -instance Bi T.EpochIndex where - encode (T.EpochIndex epoch) = encode epoch - decode = T.EpochIndex <$> decode - -instance Bi T.LocalSlotIndex where - encode = encode . T.getSlotIndex - decode = T.UnsafeLocalSlotIndex <$> decode - -deriveSimpleBi ''T.SlotId [ - Cons 'T.SlotId [ - Field [| T.siEpoch :: T.EpochIndex |], - Field [| T.siSlot :: T.LocalSlotIndex |] - ]] - -instance Bi T.EpochOrSlot where - encode (T.EpochOrSlot e) = encode e - decode = T.EpochOrSlot <$> decode @(Either T.EpochIndex T.SlotId) - -instance Bi T.SlotCount where - encode = encode . T.getSlotCount - decode = T.SlotCount <$> decode diff --git a/core/src/Pos/Binary/Core/Ssc.hs b/core/src/Pos/Binary/Core/Ssc.hs index 466681c6276..91f023dc3bf 100644 --- a/core/src/Pos/Binary/Core/Ssc.hs +++ b/core/src/Pos/Binary/Core/Ssc.hs @@ -13,7 +13,6 @@ import Serokell.Util (allDistinct) import Pos.Binary.Class (Bi (..), Cons (..), Decoder, Encoding, Field (..), deriveSimpleBi, encodeListLen, enforceSize) -import Pos.Binary.Core.Slotting () import Pos.Core.Ssc (Commitment (..), CommitmentsMap (..), Opening (..), OpeningsMap, SharesMap, SignedCommitment, SscPayload (..), SscProof (..), VssCertificate (..), VssCertificatesHash, VssCertificatesMap (..), diff --git a/core/src/Pos/Binary/Core/Txp.hs b/core/src/Pos/Binary/Core/Txp.hs deleted file mode 100644 index 46badac7832..00000000000 --- a/core/src/Pos/Binary/Core/Txp.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Binary serialization of core Txp types. - -module Pos.Binary.Core.Txp - ( - ) where - -import Universum - -import qualified Data.ByteString.Lazy as LBS - -import Pos.Binary.Class (Bi (..), Cons (..), Field (..), decodeKnownCborDataItem, - decodeListLenCanonical, decodeUnknownCborDataItem, - deriveSimpleBi, encodeKnownCborDataItem, encodeListLen, - encodeUnknownCborDataItem, enforceSize, matchSize) -import Pos.Binary.Core.Common () -import Pos.Binary.Core.Script () -import Pos.Binary.Merkle () -import qualified Pos.Core.Common as Common -import qualified Pos.Core.Txp as T - ----------------------------------------------------------------------------- --- Core ----------------------------------------------------------------------------- - -instance Bi T.TxIn where - encode T.TxInUtxo{..} = - encodeListLen 2 <> - encode (0 :: Word8) <> - encodeKnownCborDataItem (txInHash, txInIndex) - encode (T.TxInUnknown tag bs) = - encodeListLen 2 <> - encode tag <> - encodeUnknownCborDataItem (LBS.fromStrict bs) - decode = do - enforceSize "TxIn" 2 - tag <- decode @Word8 - case tag of - 0 -> uncurry T.TxInUtxo <$> decodeKnownCborDataItem - _ -> T.TxInUnknown tag <$> decodeUnknownCborDataItem - -deriveSimpleBi ''T.TxOut [ - Cons 'T.TxOut [ - Field [| T.txOutAddress :: Common.Address |], - Field [| T.txOutValue :: Common.Coin |] - ]] - -deriveSimpleBi ''T.TxOutAux [ - Cons 'T.TxOutAux [ - Field [| T.toaOut :: T.TxOut |] - ]] - -instance Bi T.Tx where - encode tx = encodeListLen 3 - <> encode (T._txInputs tx) - <> encode (T._txOutputs tx) - <> encode (T._txAttributes tx) - decode = do - enforceSize "Tx" 3 - T.UnsafeTx <$> decode <*> decode <*> decode - -instance Bi T.TxInWitness where - encode input = case input of - T.PkWitness key sig -> - encodeListLen 2 <> - encode (0 :: Word8) <> - encodeKnownCborDataItem (key, sig) - T.ScriptWitness val red -> - encodeListLen 2 <> - encode (1 :: Word8) <> - encodeKnownCborDataItem (val, red) - T.RedeemWitness key sig -> - encodeListLen 2 <> - encode (2 :: Word8) <> - encodeKnownCborDataItem (key, sig) - T.UnknownWitnessType tag bs -> - encodeListLen 2 <> - encode tag <> - encodeUnknownCborDataItem (LBS.fromStrict bs) - decode = do - len <- decodeListLenCanonical - tag <- decode @Word8 - case tag of - 0 -> do - matchSize len "TxInWitness.PkWitness" 2 - uncurry T.PkWitness <$> decodeKnownCborDataItem - 1 -> do - matchSize len "TxInWitness.ScriptWitness" 2 - uncurry T.ScriptWitness <$> decodeKnownCborDataItem - 2 -> do - matchSize len "TxInWitness.RedeemWitness" 2 - uncurry T.RedeemWitness <$> decodeKnownCborDataItem - _ -> do - matchSize len "TxInWitness.UnknownWitnessType" 2 - T.UnknownWitnessType tag <$> decodeUnknownCborDataItem - -instance Bi T.TxSigData where - encode (T.TxSigData {..}) = encode txSigTxHash - decode = T.TxSigData <$> decode - -deriveSimpleBi ''T.TxAux [ - Cons 'T.TxAux [ - Field [| T.taTx :: T.Tx |], - Field [| T.taWitness :: T.TxWitness |] - ]] - -instance Bi T.TxProof where - encode proof = encodeListLen 3 - <> encode (T.txpNumber proof) - <> encode (T.txpRoot proof) - <> encode (T.txpWitnessesHash proof) - decode = do - enforceSize "TxProof" 3 - T.TxProof <$> decode <*> - decode <*> - decode - -instance Bi T.TxPayload where - encode T.UnsafeTxPayload {..} = encode $ zip (toList _txpTxs) _txpWitnesses - decode = T.mkTxPayload <$> decode diff --git a/core/src/Pos/Binary/Core/Update.hs b/core/src/Pos/Binary/Core/Update.hs index cfe2621685b..b9e3c3f046b 100644 --- a/core/src/Pos/Binary/Core/Update.hs +++ b/core/src/Pos/Binary/Core/Update.hs @@ -13,10 +13,7 @@ import Serokell.Data.Memory.Units (Byte) import Pos.Binary.Class (Bi (..), Cons (..), Field (..), Raw, deriveSimpleBi, encodeListLen, enforceSize) -import Pos.Binary.Core.Common () -import Pos.Binary.Core.Fee () import Pos.Binary.Core.Script () -import Pos.Binary.Core.Slotting () import Pos.Core.Common (CoinPortion, ScriptVersion, TxFeePolicy) import Pos.Core.Slotting (EpochIndex, FlatSlotId) import Pos.Core.Update (ApplicationName (..), BlockVersion (..), BlockVersionData (..), diff --git a/core/src/Pos/Binary/Merkle.hs b/core/src/Pos/Binary/Merkle.hs deleted file mode 100644 index 3c5600cfef4..00000000000 --- a/core/src/Pos/Binary/Merkle.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Merkle tree-related serialization - -module Pos.Binary.Merkle () where - -import Universum - -import qualified Data.Foldable as Foldable - -import Pos.Binary.Class (Bi (..), Raw) -import Pos.Crypto.Hashing (Hash) -import Pos.Merkle (MerkleRoot (..), MerkleTree (..), mkMerkleTree) - --- This instance is both faster and more space-efficient (as confirmed by a --- benchmark). Hashing turns out to be faster than decoding extra data. -instance (Bi a, Bi (Hash Raw)) => Bi (MerkleTree a) where - encode = encode . Foldable.toList - decode = mkMerkleTree <$> decode - -instance (Bi a, Bi (Hash Raw)) => Bi (MerkleRoot a) where - encode = encode . getMerkleRoot - decode = MerkleRoot <$> decode diff --git a/core/src/Pos/Core/Block/Blockchain.hs b/core/src/Pos/Core/Block/Blockchain.hs index 6b718de0068..60971c34561 100644 --- a/core/src/Pos/Core/Block/Blockchain.hs +++ b/core/src/Pos/Core/Block/Blockchain.hs @@ -36,7 +36,8 @@ import Control.Lens (makeLenses) import Control.Monad.Except (MonadError (throwError)) import Formatting (build, sformat, (%)) -import Pos.Crypto (ProtocolMagic) +import Pos.Binary.Class (Bi (..), encodeListLen, enforceSize) +import Pos.Crypto (ProtocolMagic (..)) ---------------------------------------------------------------------------- -- Blockchain class @@ -119,6 +120,28 @@ deriving instance , Eq (ExtraHeaderData b) ) => Eq (GenericBlockHeader b) +instance ( Typeable b + , Bi (BHeaderHash b) + , Bi (BodyProof b) + , Bi (ConsensusData b) + , Bi (ExtraHeaderData b) + ) => + Bi (GenericBlockHeader b) where + encode bh = encodeListLen 5 + <> encode (getProtocolMagic (_gbhProtocolMagic bh)) + <> encode (_gbhPrevBlock bh) + <> encode (_gbhBodyProof bh) + <> encode (_gbhConsensus bh) + <> encode (_gbhExtra bh) + decode = do + enforceSize "GenericBlockHeader b" 5 + _gbhProtocolMagic <- ProtocolMagic <$> decode + _gbhPrevBlock <- decode + _gbhBodyProof <- decode + _gbhConsensus <- decode + _gbhExtra <- decode + pure UnsafeGenericBlockHeader {..} + instance ( NFData (BHeaderHash b) , NFData (BodyProof b) @@ -155,6 +178,25 @@ deriving instance , Eq (ExtraHeaderData b) ) => Eq (GenericBlock b) +instance ( Typeable b + , Bi (BHeaderHash b) + , Bi (Body b) + , Bi (BodyProof b) + , Bi (ConsensusData b) + , Bi (ExtraBodyData b) + , Bi (ExtraHeaderData b) + ) => Bi (GenericBlock b) where + encode gb = encodeListLen 3 + <> encode (_gbHeader gb) + <> encode (_gbBody gb) + <> encode (_gbExtra gb) + decode = do + enforceSize "GenericBlock" 3 + _gbHeader <- decode + _gbBody <- decode + _gbExtra <- decode + pure UnsafeGenericBlock {..} + -- Derived partially in Instances --instance -- ( NFData (GenericBlockHeader b) diff --git a/core/src/Pos/Core/Block/Constructors.hs b/core/src/Pos/Core/Block/Constructors.hs index 15653794f61..0da2ebc8c51 100644 --- a/core/src/Pos/Core/Block/Constructors.hs +++ b/core/src/Pos/Core/Block/Constructors.hs @@ -13,7 +13,6 @@ module Pos.Core.Block.Constructors import Universum -import Pos.Binary.Core.Blockchain () -- Bi instances import Pos.Core.Block.Blockchain (GenericBlock (..), mkGenericHeader) import Pos.Core.Block.Genesis (GenesisBody (..), GenesisConsensusData (..), GenesisExtraBodyData (..), GenesisExtraHeaderData (..)) diff --git a/core/src/Pos/Core/Block/Genesis/Instances.hs b/core/src/Pos/Core/Block/Genesis/Instances.hs index 8dfb37acb9c..4860f3a1f24 100644 --- a/core/src/Pos/Core/Block/Genesis/Instances.hs +++ b/core/src/Pos/Core/Block/Genesis/Instances.hs @@ -12,7 +12,6 @@ import qualified Data.Text.Buildable as Buildable import Formatting (bprint, build, int, sformat, stext, (%)) import Serokell.Util (Color (Magenta), colorize) -import Pos.Binary.Class (Bi) import Pos.Core.Block.Blockchain (GenericBlock (..), GenericBlockHeader (..), gbHeader, gbhConsensus) import Pos.Core.Block.Genesis.Lens (gcdDifficulty, gcdEpoch) @@ -30,7 +29,7 @@ instance NFData GenesisBlock -- Buildable ---------------------------------------------------------------------------- -instance Bi BlockHeader => Buildable GenesisBlockHeader where +instance Buildable GenesisBlockHeader where build gbh@UnsafeGenericBlockHeader {..} = bprint ("GenesisBlockHeader:\n"% @@ -48,7 +47,7 @@ instance Bi BlockHeader => Buildable GenesisBlockHeader where gbhHeaderHash = blockHeaderHash $ BlockHeaderGenesis gbh GenesisConsensusData {..} = _gbhConsensus -instance Bi BlockHeader => Buildable GenesisBlock where +instance Buildable GenesisBlock where build UnsafeGenericBlock {..} = bprint (stext%":\n"% @@ -76,16 +75,10 @@ instance HasEpochOrSlot GenesisBlockHeader where instance HasEpochOrSlot GenesisBlock where getEpochOrSlot = getEpochOrSlot . _gbHeader --- NB. it's not a mistake that these instances require @Bi BlockHeader@ --- instead of @Bi GenesisBlockHeader@. We compute header's hash by --- converting it to a BlockHeader first. - -instance Bi BlockHeader => - HasHeaderHash GenesisBlockHeader where +instance HasHeaderHash GenesisBlockHeader where headerHash = blockHeaderHash . BlockHeaderGenesis -instance Bi BlockHeader => - HasHeaderHash GenesisBlock where +instance HasHeaderHash GenesisBlock where headerHash = blockHeaderHash . BlockHeaderGenesis . _gbHeader instance HasDifficulty GenesisConsensusData where @@ -97,5 +90,5 @@ instance HasDifficulty GenesisBlockHeader where instance HasDifficulty GenesisBlock where difficultyL = gbHeader . difficultyL -instance Bi BlockHeader => IsHeader GenesisBlockHeader -instance Bi BlockHeader => IsGenesisHeader GenesisBlockHeader +instance IsHeader GenesisBlockHeader +instance IsGenesisHeader GenesisBlockHeader diff --git a/core/src/Pos/Core/Block/Genesis/Types.hs b/core/src/Pos/Core/Block/Genesis/Types.hs index 00e34588333..988b380ac21 100644 --- a/core/src/Pos/Core/Block/Genesis/Types.hs +++ b/core/src/Pos/Core/Block/Genesis/Types.hs @@ -15,6 +15,9 @@ import Universum import qualified Data.Text.Buildable as Buildable import Formatting (bprint, build, (%)) +import Pos.Binary.Class (Bi (..), Cons (..), Field (..), + deriveSimpleBi, encodeListLen, + enforceSize) import Pos.Core.Common (ChainDifficulty, SlotLeaders) import Pos.Core.Slotting (EpochIndex (..)) import Pos.Crypto (Hash) @@ -31,6 +34,10 @@ instance NFData GenesisProof instance Buildable GenesisProof where build (GenesisProof h) = Buildable.build h +instance Bi GenesisProof where + encode (GenesisProof h) = encode h + decode = GenesisProof <$> decode + data GenesisConsensusData = GenesisConsensusData { -- | Index of the slot for which this genesis block is relevant. _gcdEpoch :: !EpochIndex @@ -40,6 +47,14 @@ data GenesisConsensusData = GenesisConsensusData instance NFData GenesisConsensusData +instance Bi GenesisConsensusData where + encode bc = encodeListLen 2 + <> encode (_gcdEpoch bc) + <> encode (_gcdDifficulty bc) + decode = do + enforceSize "ConsensusData GenesisBlockchain" 2 + GenesisConsensusData <$> decode <*> decode + -- | Represents genesis block header attributes. type GenesisHeaderAttributes = Attributes () @@ -62,6 +77,10 @@ data GenesisBody = GenesisBody { _gbLeaders :: !SlotLeaders } deriving (Generic, Show, Eq) +instance Bi GenesisBody where + encode = encode . _gbLeaders + decode = GenesisBody <$> decode + instance NFData GenesisBody -- | Represents genesis block header attributes. @@ -79,3 +98,13 @@ instance Buildable GenesisExtraBodyData where build (GenesisExtraBodyData attrs) | areAttributesKnown attrs = "no extra data" | otherwise = bprint ("extra data has attributes: "%build) attrs + +deriveSimpleBi ''GenesisExtraHeaderData [ + Cons 'GenesisExtraHeaderData [ + Field [| _gehAttributes :: GenesisHeaderAttributes |] + ]] + +deriveSimpleBi ''GenesisExtraBodyData [ + Cons 'GenesisExtraBodyData [ + Field [| _gebAttributes :: GenesisBodyAttributes |] + ]] diff --git a/core/src/Pos/Core/Block/Main/Instances.hs b/core/src/Pos/Core/Block/Main/Instances.hs index be0e8e8de9e..4879c9764e3 100644 --- a/core/src/Pos/Core/Block/Main/Instances.hs +++ b/core/src/Pos/Core/Block/Main/Instances.hs @@ -12,7 +12,6 @@ import qualified Data.Text.Buildable as Buildable import Formatting (bprint, build, int, stext, (%)) import Serokell.Util (Color (Magenta), colorize, listJson) -import Pos.Binary.Class (Bi) import Pos.Core.Block.Blockchain (GenericBlock (..), GenericBlockHeader (..)) import Pos.Core.Block.Main.Lens (mainBlockBlockVersion, mainBlockDifficulty, mainBlockSlot, mainBlockSoftwareVersion, @@ -33,7 +32,7 @@ import Pos.Crypto (hashHexF) instance NFData MainBlock -instance Bi BlockHeader => Buildable MainBlockHeader where +instance Buildable MainBlockHeader where build gbh@UnsafeGenericBlockHeader {..} = bprint ("MainBlockHeader:\n"% @@ -57,7 +56,7 @@ instance Bi BlockHeader => Buildable MainBlockHeader where gbhHeaderHash = blockHeaderHash $ BlockHeaderMain gbh MainConsensusData {..} = _gbhConsensus -instance (Bi BlockHeader) => Buildable MainBlock where +instance Buildable MainBlock where build UnsafeGenericBlock {..} = bprint (stext%":\n"% @@ -92,16 +91,10 @@ instance HasEpochOrSlot MainBlockHeader where instance HasEpochOrSlot MainBlock where getEpochOrSlot = getEpochOrSlot . _gbHeader --- NB. it's not a mistake that these instances require @Bi BlockHeader@ --- instead of @Bi MainBlockHeader@. We compute header's hash by --- converting it to a BlockHeader first. - -instance Bi BlockHeader => - HasHeaderHash MainBlockHeader where +instance HasHeaderHash MainBlockHeader where headerHash = blockHeaderHash . BlockHeaderMain -instance Bi BlockHeader => - HasHeaderHash MainBlock where +instance HasHeaderHash MainBlock where headerHash = blockHeaderHash . BlockHeaderMain . _gbHeader instance HasDifficulty MainConsensusData where @@ -131,8 +124,8 @@ instance HasBlockVersion MainBlockHeader where instance HasSoftwareVersion MainBlockHeader where softwareVersionL = mainHeaderSoftwareVersion -instance Bi BlockHeader => IsHeader MainBlockHeader +instance IsHeader MainBlockHeader -instance Bi BlockHeader => IsMainHeader MainBlockHeader where +instance IsMainHeader MainBlockHeader where headerSlotL = mainHeaderSlot headerLeaderKeyL = mainHeaderLeaderKey diff --git a/core/src/Pos/Core/Block/Main/Types.hs b/core/src/Pos/Core/Block/Main/Types.hs index b5953c99beb..d05a656f893 100644 --- a/core/src/Pos/Core/Block/Main/Types.hs +++ b/core/src/Pos/Core/Block/Main/Types.hs @@ -16,6 +16,11 @@ import qualified Data.Text.Buildable as Buildable import Fmt (genericF) import Formatting (bprint, build, builder, (%)) +import Pos.Binary.Class (Bi (..), Cons (..), Field (..), + deriveSimpleBi, encodeListLen, + enforceSize) +import Pos.Binary.Core.Ssc () +import Pos.Binary.Core.Update () import Pos.Core.Delegation (DlgPayload) import Pos.Core.Ssc (SscPayload, SscProof) import Pos.Core.Txp (TxPayload, TxProof) @@ -36,6 +41,20 @@ instance NFData MainProof instance Buildable MainProof where build = genericF +instance Bi MainProof where + encode bc = encodeListLen 4 + <> encode (mpTxProof bc) + <> encode (mpMpcProof bc) + <> encode (mpProxySKsProof bc) + <> encode (mpUpdateProof bc) + decode = do + enforceSize "Core.BodyProof MainBlockChain" 4 + MainProof <$> decode <*> + decode <*> + decode <*> + decode + + -- | Represents main block header attributes: map from 1-byte integer to -- arbitrary-type value. To be used for extending header with new -- fields via softfork. @@ -82,6 +101,19 @@ data MainBody = MainBody , _mbUpdatePayload :: !UpdatePayload } deriving (Eq, Show, Generic, Typeable) +instance Bi MainBody where + encode bc = encodeListLen 4 + <> encode (_mbTxPayload bc) + <> encode (_mbSscPayload bc) + <> encode (_mbDlgPayload bc) + <> encode (_mbUpdatePayload bc) + decode = do + enforceSize "Body MainBlockchain" 4 + MainBody <$> decode <*> + decode <*> + decode <*> + decode + instance NFData MainBody -- | Represents main block body attributes: map from 1-byte integer to @@ -98,3 +130,16 @@ instance Buildable MainExtraBodyData where build (MainExtraBodyData attrs) | areAttributesKnown attrs = "no extra data" | otherwise = bprint ("extra data has attributes: "%build) attrs + +deriveSimpleBi ''MainExtraHeaderData [ + Cons 'MainExtraHeaderData [ + Field [| _mehBlockVersion :: BlockVersion |], + Field [| _mehSoftwareVersion :: SoftwareVersion |], + Field [| _mehAttributes :: BlockHeaderAttributes |], + Field [| _mehEBDataProof :: Hash MainExtraBodyData |] + ]] + +deriveSimpleBi ''MainExtraBodyData [ + Cons 'MainExtraBodyData [ + Field [| _mebAttributes :: BlockBodyAttributes |] + ]] diff --git a/core/src/Pos/Core/Block/Union/Instances.hs b/core/src/Pos/Core/Block/Union/Instances.hs index 524fd327f39..d059b688b75 100644 --- a/core/src/Pos/Core/Block/Union/Instances.hs +++ b/core/src/Pos/Core/Block/Union/Instances.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- the Getter instances from lens cause a redundant Functor @@ -15,7 +16,6 @@ import Universum import Control.Lens (Getter, choosing, lens, to) import qualified Data.Text.Buildable as Buildable -import Pos.Binary.Class (Bi) import Pos.Core.Block.Blockchain (GenericBlock (..)) import Pos.Core.Block.Genesis () import Pos.Core.Block.Main () @@ -31,8 +31,7 @@ import Pos.Util.Some (Some) -- Buildable ---------------------------------------------------------------------------- -instance Bi BlockHeader => - Buildable BlockHeader where +instance Buildable BlockHeader where build = \case BlockHeaderGenesis bhg -> Buildable.build bhg BlockHeaderMain bhm -> Buildable.build bhm @@ -41,12 +40,10 @@ instance Bi BlockHeader => -- HasHeaderHash ---------------------------------------------------------------------------- -instance Bi BlockHeader => - HasHeaderHash BlockHeader where +instance HasHeaderHash BlockHeader where headerHash = blockHeaderHash -instance Bi BlockHeader => - HasHeaderHash Block where +instance HasHeaderHash Block where headerHash = blockHeaderHash . getBlockHeader -- | Take 'BlockHeader' from either 'GenesisBlock' or 'MainBlock'. @@ -90,15 +87,12 @@ instance HasEpochIndex BlockHeader where -- IsHeader ---------------------------------------------------------------------------- -instance Bi BlockHeader => IsHeader BlockHeader +instance IsHeader BlockHeader ---------------------------------------------------------------------------- -- HasPrevBlock ---------------------------------------------------------------------------- -instance HasPrevBlock BlockHeader where - prevBlockL = choosingBlockHeader prevBlockL prevBlockL - instance HasPrevBlock (ComponentBlock a) where prevBlockL = lens getter setter where diff --git a/core/src/Pos/Core/Block/Union/Types.hs b/core/src/Pos/Core/Block/Union/Types.hs index e615122241a..b79890ca881 100644 --- a/core/src/Pos/Core/Block/Union/Types.hs +++ b/core/src/Pos/Core/Block/Union/Types.hs @@ -44,16 +44,15 @@ module Pos.Core.Block.Union.Types , module Pos.Core.Block.Main.Types ) where +import Codec.CBOR.Decoding (decodeWordCanonical) +import Codec.CBOR.Encoding (encodeWord) import Control.Lens (Getter, LensLike', choosing, makePrisms, to) import qualified Data.Text.Buildable as Buildable import Formatting (Format, bprint, build, (%)) import Universum -import Pos.Binary.Class (Bi) -import Pos.Binary.Core.Delegation () -import Pos.Binary.Core.Ssc () -import Pos.Binary.Core.Txp () -import Pos.Binary.Core.Update () +import Pos.Binary.Class (Bi (..), decodeListLenCanonicalOf, + encodeListLen, enforceSize) import Pos.Core.Block.Blockchain (Blockchain (..), GenericBlock (..), GenericBlockHeader (..), gbHeader, gbhPrevBlock) import Pos.Core.Block.Genesis.Types @@ -66,6 +65,7 @@ import Pos.Core.Txp (mkTxProof) import Pos.Core.Update (HasBlockVersion (..), HasSoftwareVersion (..), mkUpdateProof) import Pos.Crypto (Hash, ProtocolMagic, PublicKey, Signature, hash, unsafeHash) import Pos.Util.Some (Some, applySome, liftLensSome) +import Pos.Util.Util (cborError) ---------------------------------------------------------------------------- -- GenesisBlockchain @@ -130,6 +130,20 @@ instance Buildable BlockSignature where build (BlockPSignatureLight s) = bprint ("BlockPSignatureLight: "%build) s build (BlockPSignatureHeavy s) = bprint ("BlockPSignatureHeavy: "%build) s +instance Bi BlockSignature where + encode input = case input of + BlockSignature sig -> encodeListLen 2 <> encode (0 :: Word8) <> encode sig + BlockPSignatureLight pxy -> encodeListLen 2 <> encode (1 :: Word8) <> encode pxy + BlockPSignatureHeavy pxy -> encodeListLen 2 <> encode (2 :: Word8) <> encode pxy + decode = do + enforceSize "BlockSignature" 2 + tag <- decode @Word8 + case tag of + 0 -> BlockSignature <$> decode + 1 -> BlockPSignatureLight <$> decode + 2 -> BlockPSignatureHeavy <$> decode + _ -> cborError $ "decode@BlockSignature: unknown tag: " <> show tag + -- | Data to be signed in main block. data MainToSign = MainToSign @@ -144,6 +158,21 @@ data MainToSign deriving instance Show MainToSign deriving instance Eq MainToSign +instance Bi MainToSign where + encode mts = encodeListLen 5 + <> encode (_msHeaderHash mts) + <> encode (_msBodyProof mts) + <> encode (_msSlot mts) + <> encode (_msChainDiff mts) + <> encode (_msExtraHeader mts) + decode = do + enforceSize "MainToSign" 5 + MainToSign <$> decode <*> + decode <*> + decode <*> + decode <*> + decode + data MainConsensusData = MainConsensusData { -- | Id of the slot for which this block was generated. _mcdSlot :: !SlotId @@ -158,6 +187,19 @@ data MainConsensusData = MainConsensusData instance NFData MainConsensusData +instance Bi MainConsensusData where + encode cd = encodeListLen 4 + <> encode (_mcdSlot cd) + <> encode (_mcdLeaderKey cd) + <> encode (_mcdDifficulty cd) + <> encode (_mcdSignature cd) + decode = do + enforceSize "ConsensusData MainBlockchain)" 4 + MainConsensusData <$> decode <*> + decode <*> + decode <*> + decode + instance ( Bi BlockHeader , Bi MainProof) => Blockchain MainBlockchain where @@ -196,6 +238,14 @@ deriving instance Generic BlockHeader deriving instance (Eq GenesisBlockHeader, Eq MainBlockHeader) => Eq BlockHeader deriving instance (Show GenesisBlockHeader, Show MainBlockHeader) => Show BlockHeader +instance + ( NFData GenesisBlockHeader + , NFData MainBlockHeader + ) + => NFData BlockHeader where + rnf (BlockHeaderGenesis header) = rnf header + rnf (BlockHeaderMain header) = rnf header + choosingBlockHeader :: Functor f => LensLike' f GenesisBlockHeader r -> LensLike' f MainBlockHeader r @@ -204,6 +254,21 @@ choosingBlockHeader onGenesis onMain f = \case BlockHeaderGenesis bh -> BlockHeaderGenesis <$> onGenesis f bh BlockHeaderMain bh -> BlockHeaderMain <$> onMain f bh +instance Bi BlockHeader where + encode x = encodeListLen 2 <> encodeWord tag <> body + where + (tag, body) = case x of + BlockHeaderGenesis bh -> (0, encode bh) + BlockHeaderMain bh -> (1, encode bh) + + decode = do + decodeListLenCanonicalOf 2 + t <- decodeWordCanonical + case t of + 0 -> BlockHeaderGenesis <$!> decode + 1 -> BlockHeaderMain <$!> decode + _ -> cborError $ "decode@BlockHeader: unknown tag " <> pretty t + -- | Block. type Block = Either GenesisBlock MainBlock @@ -263,6 +328,10 @@ instance (BHeaderHash b ~ HeaderHash) => HasPrevBlock (GenericBlock b) where prevBlockL = gbHeader . gbhPrevBlock +instance HasPrevBlock BlockHeader where + prevBlockL = choosingBlockHeader prevBlockL prevBlockL + + -- | The 'ProtocolMagic' in a 'BlockHeader'. blockHeaderProtocolMagic :: BlockHeader -> ProtocolMagic blockHeaderProtocolMagic (BlockHeaderGenesis gbh) = _gbhProtocolMagic gbh diff --git a/core/src/Pos/Core/Common/BlockCount.hs b/core/src/Pos/Core/Common/BlockCount.hs index bc64850e7be..7c85a9acf75 100644 --- a/core/src/Pos/Core/Common/BlockCount.hs +++ b/core/src/Pos/Core/Common/BlockCount.hs @@ -4,8 +4,13 @@ module Pos.Core.Common.BlockCount import Universum +import Pos.Binary.Class (Bi (..)) import System.Random (Random (..)) newtype BlockCount = BlockCount {getBlockCount :: Word64} deriving (Eq, Ord, Num, Real, Integral, Enum, Read, Show, Buildable, Generic, Typeable, NFData, Hashable, Random) + +instance Bi BlockCount where + encode = encode . getBlockCount + decode = BlockCount <$> decode diff --git a/core/src/Pos/Core/Common/ChainDifficulty.hs b/core/src/Pos/Core/Common/ChainDifficulty.hs index 6006818ee5c..34306874b39 100644 --- a/core/src/Pos/Core/Common/ChainDifficulty.hs +++ b/core/src/Pos/Core/Common/ChainDifficulty.hs @@ -8,6 +8,7 @@ import Universum import Pos.Util.Some (Some, liftLensSome) +import Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi) import Pos.Core.Common.BlockCount -- | Chain difficulty represents necessary effort to generate a @@ -24,3 +25,8 @@ instance HasDifficulty (Some HasDifficulty) where isMoreDifficult :: HasDifficulty a => a -> a -> Bool a `isMoreDifficult` b = a ^. difficultyL > b ^. difficultyL + +deriveSimpleBi ''ChainDifficulty [ + Cons 'ChainDifficulty [ + Field [| getChainDifficulty :: BlockCount |] + ]] diff --git a/core/src/Pos/Core/Common/Coeff.hs b/core/src/Pos/Core/Common/Coeff.hs index d8ce3bd4fce..0f6a83e1484 100644 --- a/core/src/Pos/Core/Common/Coeff.hs +++ b/core/src/Pos/Core/Common/Coeff.hs @@ -7,6 +7,8 @@ import Universum import Data.Fixed (Fixed (..), Nano, showFixed) import qualified Data.Text.Buildable as Buildable +import Pos.Binary.Class (Bi (..)) + -- | A fractional coefficient of fixed precision. newtype Coeff = Coeff Nano deriving (Eq, Ord, Show, Generic, NFData, Num) @@ -14,4 +16,8 @@ newtype Coeff = Coeff Nano instance Buildable Coeff where build (Coeff x) = fromString (showFixed True x) +instance Bi Coeff where + encode (Coeff n) = encode n + decode = Coeff <$> decode @Nano + instance Hashable Coeff diff --git a/core/src/Pos/Core/Common/Coin.hs b/core/src/Pos/Core/Common/Coin.hs index ec2efc4aefa..2f5bd5b3fb6 100644 --- a/core/src/Pos/Core/Common/Coin.hs +++ b/core/src/Pos/Core/Common/Coin.hs @@ -29,6 +29,7 @@ import Data.Data (Data) import qualified Data.Text.Buildable import Formatting (Format, bprint, build, int, (%)) +import Pos.Binary.Class (Bi (..)) import Pos.Util.Util (leftToPanic) -- | Coin is the least possible unit of currency. @@ -43,6 +44,10 @@ instance Bounded Coin where minBound = Coin 0 maxBound = Coin maxCoinVal +instance Bi Coin where + encode = encode . unsafeGetCoin + decode = Coin <$> decode + -- | Maximal possible value of 'Coin'. maxCoinVal :: Word64 maxCoinVal = 45000000000000000 diff --git a/core/src/Pos/Core/Common/SharedSeed.hs b/core/src/Pos/Core/Common/SharedSeed.hs index 5271a7097b3..70fcc35ac31 100644 --- a/core/src/Pos/Core/Common/SharedSeed.hs +++ b/core/src/Pos/Core/Common/SharedSeed.hs @@ -10,6 +10,7 @@ import qualified Data.Semigroup (Semigroup (..)) import qualified Data.Text.Buildable as Buildable import Serokell.Util.Base16 (formatBase16) +import Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi) import Pos.Core.Constants (sharedSeedLength) -- | This is a shared seed used for follow-the-satoshi. This seed is @@ -30,3 +31,8 @@ instance Monoid SharedSeed where mempty = SharedSeed $ BSC.pack $ replicate sharedSeedLength '\NUL' mappend = (Data.Semigroup.<>) mconcat = foldl' mappend mempty + +deriveSimpleBi ''SharedSeed [ + Cons 'SharedSeed [ + Field [| getSharedSeed :: ByteString |] + ]] diff --git a/core/src/Pos/Core/Common/TxFeePolicy.hs b/core/src/Pos/Core/Common/TxFeePolicy.hs index c621b517655..9cc8dc8912d 100644 --- a/core/src/Pos/Core/Common/TxFeePolicy.hs +++ b/core/src/Pos/Core/Common/TxFeePolicy.hs @@ -4,9 +4,14 @@ module Pos.Core.Common.TxFeePolicy import Universum +import qualified Data.ByteString.Lazy as LBS +import Data.Hashable (Hashable) import qualified Data.Text.Buildable as Buildable import Formatting (bprint, build, shown, (%)) +import Pos.Binary.Class (Bi (..), decodeKnownCborDataItem, decodeUnknownCborDataItem, + encodeKnownCborDataItem, encodeUnknownCborDataItem, + encodeListLen, enforceSize) import Pos.Core.Common.TxSizeLinear -- | Transaction fee policy represents a formula to compute the minimal allowed @@ -37,4 +42,19 @@ instance Buildable TxFeePolicy where build (TxFeePolicyUnknown v bs) = bprint ("policy(unknown:"%build%"): "%shown) v bs +instance Bi TxFeePolicy where + encode policy = case policy of + TxFeePolicyTxSizeLinear txSizeLinear -> + encodeListLen 2 <> encode (0 :: Word8) + <> encodeKnownCborDataItem txSizeLinear + TxFeePolicyUnknown word8 bs -> + encodeListLen 2 <> encode word8 + <> encodeUnknownCborDataItem (LBS.fromStrict bs) + decode = do + enforceSize "TxFeePolicy" 2 + tag <- decode @Word8 + case tag of + 0 -> TxFeePolicyTxSizeLinear <$> decodeKnownCborDataItem + _ -> TxFeePolicyUnknown tag <$> decodeUnknownCborDataItem + instance Hashable TxFeePolicy diff --git a/core/src/Pos/Core/Common/TxSizeLinear.hs b/core/src/Pos/Core/Common/TxSizeLinear.hs index 25128446257..74215bb2a77 100644 --- a/core/src/Pos/Core/Common/TxSizeLinear.hs +++ b/core/src/Pos/Core/Common/TxSizeLinear.hs @@ -11,6 +11,7 @@ import qualified Data.Text.Buildable as Buildable import Formatting (bprint, build, (%)) import Serokell.Data.Memory.Units (Byte, toBytes) +import Pos.Binary.Class (Bi (..), encodeListLen, enforceSize) import Pos.Core.Common.Coeff -- | A linear equation on the transaction size. Represents the @\s -> a + b*s@ @@ -25,6 +26,14 @@ instance Buildable TxSizeLinear where build (TxSizeLinear a b) = bprint (build%" + "%build%"*s") a b +instance Bi TxSizeLinear where + encode (TxSizeLinear a b) = encodeListLen 2 <> encode a <> encode b + decode = do + enforceSize "TxSizeLinear" 2 + !a <- decode @Coeff + !b <- decode @Coeff + return $ TxSizeLinear a b + instance Hashable TxSizeLinear calculateTxSizeLinear :: TxSizeLinear -> Byte -> Nano diff --git a/core/src/Pos/Core/Delegation/HeavyDlgIndex.hs b/core/src/Pos/Core/Delegation/HeavyDlgIndex.hs index dd8772b0a92..1a0f55db562 100644 --- a/core/src/Pos/Core/Delegation/HeavyDlgIndex.hs +++ b/core/src/Pos/Core/Delegation/HeavyDlgIndex.hs @@ -10,6 +10,7 @@ import Universum import qualified Data.Text.Buildable import Formatting (bprint, build) +import Pos.Binary.Class (Bi (..)) import Pos.Core.Slotting (EpochIndex) import Pos.Crypto (ProxySecretKey (..), ProxySignature, PublicKey) @@ -27,6 +28,10 @@ instance Hashable HeavyDlgIndex instance Buildable HeavyDlgIndex where build (HeavyDlgIndex i) = bprint build i +instance Bi HeavyDlgIndex where + encode = encode . getHeavyDlgIndex + decode = HeavyDlgIndex <$> decode + -- | Simple proxy signature without ttl/epoch index constraints. type ProxySigHeavy a = ProxySignature HeavyDlgIndex a diff --git a/core/src/Pos/Core/Delegation/LightDlgIndices.hs b/core/src/Pos/Core/Delegation/LightDlgIndices.hs index 03884f49237..5eaa6658efa 100644 --- a/core/src/Pos/Core/Delegation/LightDlgIndices.hs +++ b/core/src/Pos/Core/Delegation/LightDlgIndices.hs @@ -10,6 +10,7 @@ import qualified Data.Text.Buildable import Formatting (bprint) import Serokell.Util (pairF) +import Pos.Binary.Class (Bi (..)) import Pos.Core.Slotting (EpochIndex) import Pos.Crypto (ProxySecretKey (..), ProxySignature) @@ -29,6 +30,10 @@ instance NFData LightDlgIndices instance Buildable LightDlgIndices where build (LightDlgIndices p) = bprint pairF p +instance Bi LightDlgIndices where + encode = encode . getLightDlgIndices + decode = LightDlgIndices <$> decode + -- | Light delegation proxy signature, that holds a pair of epoch -- indices. type ProxySigLight a = ProxySignature LightDlgIndices a diff --git a/core/src/Pos/Core/Delegation/Payload.hs b/core/src/Pos/Core/Delegation/Payload.hs index ee8570d7e4a..5fc046e17eb 100644 --- a/core/src/Pos/Core/Delegation/Payload.hs +++ b/core/src/Pos/Core/Delegation/Payload.hs @@ -11,7 +11,7 @@ import qualified Data.Text.Buildable import Formatting (bprint, int, (%)) import Serokell.Util (allDistinct, listJson) -import Pos.Binary.Class (Bi) +import Pos.Binary.Class (Bi (..)) import Pos.Crypto (ProtocolMagic, ProxySecretKey (..), validateProxySecretKey) import Pos.Core.Delegation.HeavyDlgIndex @@ -31,8 +31,12 @@ instance Buildable DlgPayload where ("proxy signing keys ("%int%" items): "%listJson%"\n") (length psks) psks -checkDlgPayload :: - (MonadError Text m, Bi HeavyDlgIndex) +instance Bi DlgPayload where + encode = encode . getDlgPayload + decode = UnsafeDlgPayload <$> decode + +checkDlgPayload + :: MonadError Text m => ProtocolMagic -> DlgPayload -> m () diff --git a/core/src/Pos/Core/Delegation/Proof.hs b/core/src/Pos/Core/Delegation/Proof.hs index c8e76e2d5be..4af00b69f3c 100644 --- a/core/src/Pos/Core/Delegation/Proof.hs +++ b/core/src/Pos/Core/Delegation/Proof.hs @@ -3,7 +3,6 @@ module Pos.Core.Delegation.Proof , mkDlgProof ) where -import Pos.Binary.Class (Bi) import Pos.Crypto (Hash, hash) import Pos.Core.Delegation.Payload @@ -12,5 +11,5 @@ import Pos.Core.Delegation.Payload type DlgProof = Hash DlgPayload -- | Creates 'DlgProof' out of delegation payload. -mkDlgProof :: Bi DlgPayload => DlgPayload -> DlgProof +mkDlgProof :: DlgPayload -> DlgProof mkDlgProof = hash diff --git a/core/src/Pos/Core/Genesis/Generate.hs b/core/src/Pos/Core/Genesis/Generate.hs index 1637992cca9..d4418e62de7 100644 --- a/core/src/Pos/Core/Genesis/Generate.hs +++ b/core/src/Pos/Core/Genesis/Generate.hs @@ -25,8 +25,6 @@ import Serokell.Util.Verify (VerificationRes (..), formatAllErrors, ve import Pos.Binary.Class (asBinary, serialize') import Pos.Binary.Core.Address () -import Pos.Binary.Core.Delegation () -import Pos.Binary.Core.Slotting () import Pos.Core.Common (Address, Coin, IsBootstrapEraAddr (..), StakeholderId, addressHash, applyCoinPortionDown, coinToInteger, deriveFirstHDAddress, makePubKeyAddressBoot, mkCoin, sumCoins, diff --git a/core/src/Pos/Core/Slotting/EpochIndex.hs b/core/src/Pos/Core/Slotting/EpochIndex.hs index a430b575942..d39e70bf5ea 100644 --- a/core/src/Pos/Core/Slotting/EpochIndex.hs +++ b/core/src/Pos/Core/Slotting/EpochIndex.hs @@ -10,6 +10,7 @@ import Control.Lens (choosing) import Data.Ix (Ix) import qualified Data.Text.Buildable as Buildable import Formatting (bprint, int, (%)) +import Pos.Binary.Class (Bi (..)) import Pos.Util.Some (Some, liftLensSome) -- | Index of epoch. @@ -30,6 +31,10 @@ instance (HasEpochIndex a, HasEpochIndex b) => HasEpochIndex (Either a b) where epochIndexL = choosing epochIndexL epochIndexL +instance Bi EpochIndex where + encode (EpochIndex epoch) = encode epoch + decode = EpochIndex <$> decode + -- | Bootstrap era is ongoing until stakes are unlocked. The reward era starts -- from the epoch specified as the epoch that unlocks stakes: -- diff --git a/core/src/Pos/Core/Slotting/EpochOrSlot.hs b/core/src/Pos/Core/Slotting/EpochOrSlot.hs index 1ab933cd065..dee3937eae9 100644 --- a/core/src/Pos/Core/Slotting/EpochOrSlot.hs +++ b/core/src/Pos/Core/Slotting/EpochOrSlot.hs @@ -19,6 +19,7 @@ import Control.Lens (Getter, lens, to) import qualified Data.Text.Buildable as Buildable import Pos.Util.Some (Some, applySome) +import Pos.Binary.Class (Bi (..)) import Pos.Core.Configuration.Protocol (HasProtocolConstants, epochSlots) import Pos.Util.Util (leftToPanic) @@ -47,6 +48,11 @@ instance Ord EpochOrSlot where instance Buildable EpochOrSlot where build = either Buildable.build Buildable.build . unEpochOrSlot +instance Bi EpochOrSlot where + encode (EpochOrSlot e) = encode e + decode = EpochOrSlot <$> decode @(Either EpochIndex SlotId) + + instance HasEpochIndex EpochOrSlot where epochIndexL = lens (epochOrSlot identity siEpoch) setter where diff --git a/core/src/Pos/Core/Slotting/LocalSlotIndex.hs b/core/src/Pos/Core/Slotting/LocalSlotIndex.hs index 2bcc45fafee..424ad001645 100644 --- a/core/src/Pos/Core/Slotting/LocalSlotIndex.hs +++ b/core/src/Pos/Core/Slotting/LocalSlotIndex.hs @@ -20,6 +20,7 @@ import Control.Monad.Except (MonadError (throwError)) import Data.Ix (Ix) import System.Random (Random (..)) +import Pos.Binary.Class (Bi (..)) import Pos.Core.Configuration.Protocol (HasProtocolConstants, epochSlots, protocolConstants) import Pos.Core.ProtocolConstants (ProtocolConstants, pcEpochSlots) @@ -48,6 +49,10 @@ instance HasProtocolConstants => Bounded LocalSlotIndex where minBound = UnsafeLocalSlotIndex 0 maxBound = UnsafeLocalSlotIndex (fromIntegral epochSlots - 1) +instance Bi LocalSlotIndex where + encode = encode . getSlotIndex + decode = UnsafeLocalSlotIndex <$> decode + localSlotIndexMinBound :: LocalSlotIndex localSlotIndexMinBound = UnsafeLocalSlotIndex 0 diff --git a/core/src/Pos/Core/Slotting/SlotCount.hs b/core/src/Pos/Core/Slotting/SlotCount.hs index 077e52baf86..23d7db8fa36 100644 --- a/core/src/Pos/Core/Slotting/SlotCount.hs +++ b/core/src/Pos/Core/Slotting/SlotCount.hs @@ -6,6 +6,12 @@ import Universum import System.Random (Random (..)) +import Pos.Binary.Class (Bi (..)) + newtype SlotCount = SlotCount {getSlotCount :: Word64} deriving (Eq, Ord, Num, Real, Integral, Enum, Read, Show, Buildable, Generic, Typeable, NFData, Hashable, Random) + +instance Bi SlotCount where + encode = encode . getSlotCount + decode = SlotCount <$> decode diff --git a/core/src/Pos/Core/Slotting/SlotId.hs b/core/src/Pos/Core/Slotting/SlotId.hs index ba8ab4bb84b..aad5bef4662 100644 --- a/core/src/Pos/Core/Slotting/SlotId.hs +++ b/core/src/Pos/Core/Slotting/SlotId.hs @@ -22,6 +22,7 @@ import Control.Lens (Iso', iso, lens, makeLensesFor) import qualified Data.Text.Buildable as Buildable import Formatting (Format, bprint, build, ords, (%)) +import Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi) import Pos.Core.Configuration.Protocol (HasProtocolConstants, epochSlots, slotSecurityParam) import Pos.Util.Util (leftToPanic) @@ -101,3 +102,11 @@ crucialSlot epochIdx = SlotId {siEpoch = epochIdx - 1, ..} siSlot = leftToPanic "crucialSlot: " $ mkLocalSlotIndex (fromIntegral (fromIntegral epochSlots - slotSecurityParam - 1)) + +-- TH instances + +deriveSimpleBi ''SlotId [ + Cons 'SlotId [ + Field [| siEpoch :: EpochIndex |], + Field [| siSlot :: LocalSlotIndex |] + ]] diff --git a/core/src/Pos/Core/Slotting/TimeDiff.hs b/core/src/Pos/Core/Slotting/TimeDiff.hs index b47c09d4a9c..3acec03cb6a 100644 --- a/core/src/Pos/Core/Slotting/TimeDiff.hs +++ b/core/src/Pos/Core/Slotting/TimeDiff.hs @@ -10,6 +10,7 @@ import qualified Data.Text.Buildable as Buildable import Data.Time.Units (Microsecond) import qualified Prelude +import Pos.Binary.Class (Bi (..)) import Pos.Core.Slotting.Timestamp -- | Difference between two timestamps @@ -26,6 +27,10 @@ instance Read TimeDiff where instance Buildable TimeDiff where build = Buildable.build . toInteger +instance Bi TimeDiff where + encode = encode . toInteger + decode = fromInteger <$> decode + instance NFData TimeDiff where rnf TimeDiff{..} = rnf (toInteger getTimeDiff) diff --git a/core/src/Pos/Core/Slotting/Timestamp.hs b/core/src/Pos/Core/Slotting/Timestamp.hs index d19a48304ba..720fba0f4ae 100644 --- a/core/src/Pos/Core/Slotting/Timestamp.hs +++ b/core/src/Pos/Core/Slotting/Timestamp.hs @@ -23,6 +23,8 @@ import Mockable (CurrentTime, Mockable, currentTime) import Numeric.Lens (dividing) import qualified Prelude +import Pos.Binary.Class (Bi (..)) + -- | Timestamp is a number which represents some point in time. It is -- used in MonadSlots and its meaning is up to implementation of this -- type class. The only necessary knowledge is that difference between @@ -49,6 +51,10 @@ instance Buildable Timestamp where instance NFData Timestamp where rnf Timestamp{..} = rnf (toInteger getTimestamp) +instance Bi Timestamp where + encode (Timestamp ms) = encode . toInteger $ ms + decode = Timestamp . fromIntegral <$> decode @Integer + -- | Specialized formatter for 'Timestamp' data type. timestampF :: Format r (Timestamp -> r) timestampF = build diff --git a/core/src/Pos/Core/Ssc/Payload.hs b/core/src/Pos/Core/Ssc/Payload.hs index 54552c3a736..e7b8f8b9e61 100644 --- a/core/src/Pos/Core/Ssc/Payload.hs +++ b/core/src/Pos/Core/Ssc/Payload.hs @@ -12,8 +12,6 @@ import Data.Text.Lazy.Builder (Builder) import Formatting (Format, bprint, int, (%)) import Serokell.Util (listJson) -import Pos.Binary.Class (Bi) -import Pos.Core.Slotting (EpochIndex) import Pos.Crypto (ProtocolMagic, shortHashF) import Pos.Core.Ssc.CommitmentsMap @@ -86,7 +84,7 @@ isEmptySscPayload (SharesPayload shares certs) = null shares && null certs isEmptySscPayload (CertificatesPayload certs) = null certs checkSscPayload - :: ( MonadError Text m, Bi EpochIndex ) + :: MonadError Text m => ProtocolMagic -> SscPayload -> m () diff --git a/core/src/Pos/Core/Ssc/VssCertificate.hs b/core/src/Pos/Core/Ssc/VssCertificate.hs index b14f336b830..e82b97479b3 100644 --- a/core/src/Pos/Core/Ssc/VssCertificate.hs +++ b/core/src/Pos/Core/Ssc/VssCertificate.hs @@ -22,7 +22,7 @@ import qualified Data.Text.Buildable as Buildable import Formatting (bprint, build, int, (%)) import Pos.Core.Common (StakeholderId, addressHash) -import Pos.Binary.Class (AsBinary, Bi) +import Pos.Binary.Class (AsBinary) import Pos.Core.Slotting (EpochIndex) import Pos.Crypto (ProtocolMagic, PublicKey, SecretKey, SignTag (SignVssCert), Signature, VssPublicKey, checkSig, sign, toPublic) @@ -74,8 +74,7 @@ instance Hashable VssCertificate where -- | Make VssCertificate valid up to given epoch using 'SecretKey' to sign -- data. mkVssCertificate - :: (Bi EpochIndex) - => ProtocolMagic + :: ProtocolMagic -> SecretKey -> AsBinary VssPublicKey -> EpochIndex @@ -87,7 +86,7 @@ mkVssCertificate pm sk vk expiry = -- | Check a 'VssCertificate' for validity. checkVssCertificate - :: (Bi EpochIndex, MonadError Text m) + :: (MonadError Text m) => ProtocolMagic -> VssCertificate -> m () @@ -98,7 +97,7 @@ checkVssCertificate pm it = -- | Check that the VSS certificate is signed properly -- #checkPubKeyAddress -- #checkSig -checkCertSign :: (Bi EpochIndex) => ProtocolMagic -> VssCertificate -> Bool +checkCertSign :: ProtocolMagic -> VssCertificate -> Bool checkCertSign pm UnsafeVssCertificate {..} = checkSig pm SignVssCert vcSigningKey (vcVssKey, vcExpiryEpoch) vcSignature diff --git a/core/src/Pos/Core/Ssc/VssCertificatesMap.hs b/core/src/Pos/Core/Ssc/VssCertificatesMap.hs index 89413b419c4..0dd41a3d1b8 100644 --- a/core/src/Pos/Core/Ssc/VssCertificatesMap.hs +++ b/core/src/Pos/Core/Ssc/VssCertificatesMap.hs @@ -25,9 +25,7 @@ import Data.List.Extra (nubOrdOn) import Formatting (build, sformat, (%)) import Serokell.Util (allDistinct) -import Pos.Binary.Class (Bi) import Pos.Core.Common (StakeholderId) -import Pos.Core.Slotting (EpochIndex) import Pos.Crypto (ProtocolMagic) import Pos.Core.Ssc.VssCertificate (VssCertificate (..), checkVssCertificate, getCertId, @@ -66,7 +64,7 @@ mkVssCertificatesMap = UnsafeVssCertificatesMap . HM.fromList . map toCertPair -- 'vcVssKey's. Also checks every VssCertificate in the map (see -- 'checkVssCertificate'). checkVssCertificatesMap - :: (Bi EpochIndex, MonadError Text m) + :: (MonadError Text m) => ProtocolMagic -> VssCertificatesMap -> m () diff --git a/core/src/Pos/Core/Txp/Tx.hs b/core/src/Pos/Core/Txp/Tx.hs index b5013e33e5f..5aeca7c2360 100644 --- a/core/src/Pos/Core/Txp/Tx.hs +++ b/core/src/Pos/Core/Txp/Tx.hs @@ -20,13 +20,17 @@ import Universum import Control.Lens (makeLenses, makePrisms) import Control.Monad.Except (MonadError (throwError)) +import qualified Data.ByteString.Lazy as BSL import qualified Data.Text.Buildable as Buildable import Formatting (Format, bprint, build, builder, int, sformat, (%)) import Serokell.Util.Base16 (base16F) import Serokell.Util.Text (listJson) import Serokell.Util.Verify (VerificationRes (..), verResSingleF, verifyGeneric) -import Pos.Binary.Class (Bi) +import Pos.Binary.Class (Bi (..), Cons (..), Field (..), + encodeListLen, encodeKnownCborDataItem, enforceSize, + encodeUnknownCborDataItem, decodeKnownCborDataItem, + decodeUnknownCborDataItem, deriveSimpleBi) import Pos.Core.Common (Address (..), Coin (..), checkCoin, coinF) import Pos.Crypto (Hash, hash, shortHashF) import Pos.Data.Attributes (Attributes, areAttributesKnown) @@ -46,7 +50,7 @@ data Tx = UnsafeTx instance Hashable Tx -instance Bi Tx => Buildable Tx where +instance Buildable Tx where build tx@(UnsafeTx{..}) = bprint ("Tx "%build% @@ -57,10 +61,19 @@ instance Bi Tx => Buildable Tx where attrsBuilder | areAttributesKnown attrs = mempty | otherwise = bprint (", attributes: "%build) attrs +instance Bi Tx where + encode tx = encodeListLen 3 + <> encode (_txInputs tx) + <> encode (_txOutputs tx) + <> encode (_txAttributes tx) + decode = do + enforceSize "Tx" 3 + UnsafeTx <$> decode <*> decode <*> decode + instance NFData Tx -- | Specialized formatter for 'Tx'. -txF :: Bi Tx => Format r (Tx -> r) +txF :: Format r (Tx -> r) txF = build -- | Verify inputs and outputs are non empty; have enough coins. @@ -126,6 +139,22 @@ instance Buildable TxIn where build TxInUtxo {..} = bprint ("TxInUtxo "%shortHashF%" #"%int) txInHash txInIndex build (TxInUnknown tag bs) = bprint ("TxInUnknown "%int%" "%base16F) tag bs +instance Bi TxIn where + encode TxInUtxo{..} = + encodeListLen 2 <> + encode (0 :: Word8) <> + encodeKnownCborDataItem (txInHash, txInIndex) + encode (TxInUnknown tag bs) = + encodeListLen 2 <> + encode tag <> + encodeUnknownCborDataItem (BSL.fromStrict bs) + decode = do + enforceSize "TxIn" 2 + tag <- decode @Word8 + case tag of + 0 -> uncurry TxInUtxo <$> decodeKnownCborDataItem + _ -> TxInUnknown tag <$> decodeUnknownCborDataItem + instance NFData TxIn isTxInUnknown :: TxIn -> Bool @@ -157,3 +186,9 @@ makePrisms ''TxOut -------------------------------------------------------------------------------- makeLenses ''Tx + +deriveSimpleBi ''TxOut [ + Cons 'TxOut [ + Field [| txOutAddress :: Address |], + Field [| txOutValue :: Coin |] + ]] diff --git a/core/src/Pos/Core/Txp/TxAux.hs b/core/src/Pos/Core/Txp/TxAux.hs index bdfaeda2d84..50d92ce4bfe 100644 --- a/core/src/Pos/Core/Txp/TxAux.hs +++ b/core/src/Pos/Core/Txp/TxAux.hs @@ -11,7 +11,7 @@ import qualified Data.Text.Buildable as Buildable import Formatting (Format, bprint, build, later, (%)) import Serokell.Util.Text (listJsonIndent) -import Pos.Binary.Class (Bi) +import Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi) import Pos.Core.Txp.Tx import Pos.Core.Txp.TxWitness @@ -25,11 +25,11 @@ data TxAux = TxAux instance NFData TxAux -- | Specialized formatter for 'TxAux'. -txaF :: Bi Tx => Format r (TxAux -> r) +txaF :: Format r (TxAux -> r) txaF = later $ \(TxAux tx w) -> bprint (build%"\n"%"witnesses: "%listJsonIndent 4) tx w -instance Bi Tx => Buildable TxAux where +instance Buildable TxAux where build = bprint txaF -- | Check that a 'TxAux' is internally valid (checks that its 'Tx' is valid @@ -39,3 +39,9 @@ checkTxAux => TxAux -> m () checkTxAux TxAux{..} = checkTx taTx + +deriveSimpleBi ''TxAux [ + Cons 'TxAux [ + Field [| taTx :: Tx |], + Field [| taWitness :: TxWitness |] + ]] diff --git a/core/src/Pos/Core/Txp/TxOutAux.hs b/core/src/Pos/Core/Txp/TxOutAux.hs index e58fc49ef3d..aa97e82844c 100644 --- a/core/src/Pos/Core/Txp/TxOutAux.hs +++ b/core/src/Pos/Core/Txp/TxOutAux.hs @@ -7,6 +7,7 @@ import Universum import qualified Data.Text.Buildable as Buildable import Formatting (bprint, build, (%)) +import Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi) import Pos.Core.Txp.Tx (TxOut) -- | Transaction output and auxilary data corresponding to it. @@ -20,3 +21,8 @@ instance Buildable TxOutAux where build (TxOutAux out) = bprint ("{txout = "%build%"}") out instance NFData TxOutAux + +deriveSimpleBi ''TxOutAux [ + Cons 'TxOutAux [ + Field [| toaOut :: TxOut |] + ]] diff --git a/core/src/Pos/Core/Txp/TxPayload.hs b/core/src/Pos/Core/Txp/TxPayload.hs index f485fc0cb3f..26286de398f 100644 --- a/core/src/Pos/Core/Txp/TxPayload.hs +++ b/core/src/Pos/Core/Txp/TxPayload.hs @@ -11,6 +11,7 @@ import Universum import Control.Lens (makeLenses) import Control.Monad.Except (MonadError) +import Pos.Binary.Class (Bi (..)) import Pos.Core.Txp.Tx import Pos.Core.Txp.TxAux import Pos.Core.Txp.TxWitness @@ -43,6 +44,10 @@ mkTxPayload txws = do unzip . map (liftA2 (,) taTx taWitness) $ txws _txpTxs = txs +instance Bi TxPayload where + encode UnsafeTxPayload {..} = encode $ zip (toList _txpTxs) _txpWitnesses + decode = mkTxPayload <$> decode + -- | Check a TxPayload by checking all of the Txs it contains. checkTxPayload :: MonadError Text m => TxPayload -> m () checkTxPayload it = forM_ (_txpTxs it) checkTx diff --git a/core/src/Pos/Core/Txp/TxProof.hs b/core/src/Pos/Core/Txp/TxProof.hs index 904564d7e21..9e38a04fa37 100644 --- a/core/src/Pos/Core/Txp/TxProof.hs +++ b/core/src/Pos/Core/Txp/TxProof.hs @@ -8,7 +8,7 @@ import Universum import qualified Data.Text.Buildable as Buildable import Fmt (genericF) -import Pos.Binary.Class (Bi) +import Pos.Binary.Class (Bi (..), encodeListLen, enforceSize) import Pos.Crypto (Hash, hash) import Pos.Merkle (MerkleRoot, mkMerkleTree, mtRoot) @@ -25,12 +25,23 @@ data TxProof = TxProof instance Buildable TxProof where build = genericF +instance Bi TxProof where + encode proof = encodeListLen 3 + <> encode (txpNumber proof) + <> encode (txpRoot proof) + <> encode (txpWitnessesHash proof) + decode = do + enforceSize "TxProof" 3 + TxProof <$> decode <*> + decode <*> + decode + instance NFData TxProof -- | Construct 'TxProof' which proves given 'TxPayload'. -- This will construct a merkle tree, which can be very expensive. Use with -- care. Bi constraints arise because we need to hash these things. -mkTxProof :: (Bi Tx, Bi TxInWitness) => TxPayload -> TxProof +mkTxProof :: Bi TxInWitness => TxPayload -> TxProof mkTxProof UnsafeTxPayload {..} = TxProof { txpNumber = fromIntegral (length _txpTxs) diff --git a/core/src/Pos/Core/Txp/TxWitness.hs b/core/src/Pos/Core/Txp/TxWitness.hs index 9b86591195d..ad54a543576 100644 --- a/core/src/Pos/Core/Txp/TxWitness.hs +++ b/core/src/Pos/Core/Txp/TxWitness.hs @@ -7,10 +7,15 @@ module Pos.Core.Txp.TxWitness import Universum +import qualified Data.ByteString.Lazy as BSL import qualified Data.Text.Buildable as Buildable import Formatting (bprint, build, (%)) import Serokell.Util.Base16 (base16F) +import Pos.Binary.Class (Bi (..), encodeListLen, encodeKnownCborDataItem, + encodeUnknownCborDataItem, decodeKnownCborDataItem, + decodeUnknownCborDataItem, decodeListLenCanonical, + matchSize) import Pos.Core.Common (Script, addressHash) import Pos.Crypto (Hash, PublicKey, RedeemPublicKey, RedeemSignature, Signature, hash, shortHashF) @@ -48,6 +53,41 @@ instance Buildable TxInWitness where build (UnknownWitnessType t bs) = bprint ("UnknownWitnessType "%build%" "%base16F) t bs +instance Bi TxInWitness where + encode input = case input of + PkWitness key sig -> + encodeListLen 2 <> + encode (0 :: Word8) <> + encodeKnownCborDataItem (key, sig) + ScriptWitness val red -> + encodeListLen 2 <> + encode (1 :: Word8) <> + encodeKnownCborDataItem (val, red) + RedeemWitness key sig -> + encodeListLen 2 <> + encode (2 :: Word8) <> + encodeKnownCborDataItem (key, sig) + UnknownWitnessType tag bs -> + encodeListLen 2 <> + encode tag <> + encodeUnknownCborDataItem (BSL.fromStrict bs) + decode = do + len <- decodeListLenCanonical + tag <- decode @Word8 + case tag of + 0 -> do + matchSize len "TxInWitness.PkWitness" 2 + uncurry PkWitness <$> decodeKnownCborDataItem + 1 -> do + matchSize len "TxInWitness.ScriptWitness" 2 + uncurry ScriptWitness <$> decodeKnownCborDataItem + 2 -> do + matchSize len "TxInWitness.RedeemWitness" 2 + uncurry RedeemWitness <$> decodeKnownCborDataItem + _ -> do + matchSize len "TxInWitness.UnknownWitnessType" 2 + UnknownWitnessType tag <$> decodeUnknownCborDataItem + instance NFData TxInWitness -- | Data that is being signed when creating a TxSig. @@ -57,5 +97,9 @@ data TxSigData = TxSigData } deriving (Eq, Show, Generic, Typeable) +instance Bi TxSigData where + encode (TxSigData {..}) = encode txSigTxHash + decode = TxSigData <$> decode + -- | 'Signature' of addrId. type TxSig = Signature TxSigData diff --git a/core/src/Pos/Core/Update/Types.hs b/core/src/Pos/Core/Update/Types.hs index d81e08861f2..98d8ab37f94 100644 --- a/core/src/Pos/Core/Update/Types.hs +++ b/core/src/Pos/Core/Update/Types.hs @@ -61,7 +61,9 @@ import qualified Prelude import Serokell.Data.Memory.Units (Byte, memory) import Serokell.Util.Text (listJson) -import Pos.Binary.Class (Bi, Raw) +import Pos.Binary.Class (Bi (..), Cons (..), Field (..), Raw, + encodeListLen, enforceSize, + deriveSimpleBi) import Pos.Core.Common (CoinPortion, ScriptVersion, TxFeePolicy, addressHash) import Pos.Core.Slotting.Types (EpochIndex, FlatSlotId) import Pos.Crypto (Hash, ProtocolMagic, PublicKey, SafeSigner, SecretKey, @@ -85,6 +87,10 @@ newtype ApplicationName = ApplicationName { getApplicationName :: Text } deriving (Eq, Ord, Show, Generic, Typeable, ToString, Hashable, Buildable, NFData) +instance Bi ApplicationName where + encode appName = encode (getApplicationName appName) + decode = ApplicationName <$> decode + -- | Smart constructor of 'ApplicationName'. checkApplicationName :: MonadError Text m => ApplicationName -> m () checkApplicationName (ApplicationName appName) @@ -294,6 +300,10 @@ instance Buildable BlockVersionModifier where newtype SystemTag = SystemTag { getSystemTag :: Text } deriving (Eq, Ord, Show, Generic, Buildable, Hashable, Lift, Typeable) +instance Bi SystemTag where + encode = encode . getSystemTag + decode = SystemTag <$> decode + systemTagMaxLength :: Integral i => i systemTagMaxLength = 10 @@ -340,7 +350,33 @@ type UpdateProposals = HashMap UpId UpdateProposal instance Hashable UpdateProposal -instance Bi UpdateProposal => Buildable UpdateProposal where +instance Bi UpdateProposal where + encode up = encodeListLen 7 + <> encode (upBlockVersion up) + <> encode (upBlockVersionMod up) + <> encode (upSoftwareVersion up) + <> encode (upData up) + <> encode (upAttributes up) + <> encode (upFrom up) + <> encode (upSignature up) + decode = do + enforceSize "UpdateProposal" 7 + UnsafeUpdateProposal <$> decode + <*> decode + <*> decode + <*> decode + <*> decode + <*> decode + <*> decode + +instance Buildable (UpdateProposal, [UpdateVote]) where + build (up, votes) = + bprint + (build % " with votes: " %listJson) + up + (map formatVoteShort votes) + +instance Buildable UpdateProposal where build up@UnsafeUpdateProposal {..} = bprint (build% " { block v"%build% @@ -361,14 +397,6 @@ instance Bi UpdateProposal => Buildable UpdateProposal where | areAttributesKnown upAttributes = "no attributes" | otherwise = bprint ("attributes: " %build) attrs -instance (Bi UpdateProposal) => - Buildable (UpdateProposal, [UpdateVote]) where - build (up, votes) = - bprint - (build % " with votes: " %listJson) - up - (map formatVoteShort votes) - -- | Data which describes update. It is specific for each system. data UpdateData = UpdateData { udAppDiffHash :: !(Hash Raw) @@ -437,6 +465,20 @@ instance Buildable UpdateVote where bprint ("Update Vote { voter: "%build%", proposal id: "%build%", voter's decision: "%build%" }") (addressHash uvKey) uvProposalId uvDecision +instance Bi UpdateVote where + encode uv = encodeListLen 4 + <> encode (uvKey uv) + <> encode (uvProposalId uv) + <> encode (uvDecision uv) + <> encode (uvSignature uv) + decode = do + enforceSize "UpdateVote" 4 + uvKey <- decode + uvProposalId <- decode + uvDecision <- decode + uvSignature <- decode + pure UnsafeUpdateVote{..} + instance Buildable VoteId where build (upId, pk, dec) = bprint ("Vote Id { voter: "%build%", proposal id: "%build%", voter's decision: "%build%" }") @@ -491,7 +533,7 @@ data UpdatePayload = UpdatePayload instance NFData UpdatePayload -instance (Bi UpdateProposal) => Buildable UpdatePayload where +instance Buildable UpdatePayload where build UpdatePayload {..} | null upVotes = formatMaybeProposal upProposal <> ", no votes" | otherwise = @@ -500,7 +542,7 @@ instance (Bi UpdateProposal) => Buildable UpdatePayload where ("\n votes: "%listJson) (map formatVoteShort upVotes) -formatMaybeProposal :: Bi UpdateProposal => Maybe UpdateProposal -> Builder +formatMaybeProposal :: Maybe UpdateProposal -> Builder formatMaybeProposal = maybe "no proposal" Buildable.build instance Default UpdatePayload where @@ -513,3 +555,82 @@ mkUpdateProof :: Bi UpdatePayload => UpdatePayload -> UpdateProof mkUpdateProof = hash + +deriveSimpleBi ''BlockVersion [ + Cons 'BlockVersion [ + Field [| bvMajor :: Word16 |], + Field [| bvMinor :: Word16 |], + Field [| bvAlt :: Word8 |] + ]] + +deriveSimpleBi ''SoftwareVersion [ + Cons 'SoftwareVersion [ + Field [| svAppName :: ApplicationName |], + Field [| svNumber :: NumSoftwareVersion |] + ]] + +deriveSimpleBi ''SoftforkRule [ + Cons 'SoftforkRule [ + Field [| srInitThd :: CoinPortion |], + Field [| srMinThd :: CoinPortion |], + Field [| srThdDecrement :: CoinPortion |] + ]] + +deriveSimpleBi ''BlockVersionData [ + Cons 'BlockVersionData [ + Field [| bvdScriptVersion :: ScriptVersion |], + Field [| bvdSlotDuration :: Millisecond |], + Field [| bvdMaxBlockSize :: Byte |], + Field [| bvdMaxHeaderSize :: Byte |], + Field [| bvdMaxTxSize :: Byte |], + Field [| bvdMaxProposalSize :: Byte |], + Field [| bvdMpcThd :: CoinPortion |], + Field [| bvdHeavyDelThd :: CoinPortion |], + Field [| bvdUpdateVoteThd :: CoinPortion |], + Field [| bvdUpdateProposalThd :: CoinPortion |], + Field [| bvdUpdateImplicit :: FlatSlotId |], + Field [| bvdSoftforkRule :: SoftforkRule |], + Field [| bvdTxFeePolicy :: TxFeePolicy |], + Field [| bvdUnlockStakeEpoch :: EpochIndex |] + ]] + +deriveSimpleBi ''BlockVersionModifier [ + Cons 'BlockVersionModifier [ + Field [| bvmScriptVersion :: Maybe ScriptVersion |], + Field [| bvmSlotDuration :: Maybe Millisecond |], + Field [| bvmMaxBlockSize :: Maybe Byte |], + Field [| bvmMaxHeaderSize :: Maybe Byte |], + Field [| bvmMaxTxSize :: Maybe Byte |], + Field [| bvmMaxProposalSize :: Maybe Byte |], + Field [| bvmMpcThd :: Maybe CoinPortion |], + Field [| bvmHeavyDelThd :: Maybe CoinPortion |], + Field [| bvmUpdateVoteThd :: Maybe CoinPortion |], + Field [| bvmUpdateProposalThd :: Maybe CoinPortion |], + Field [| bvmUpdateImplicit :: Maybe FlatSlotId |], + Field [| bvmSoftforkRule :: Maybe SoftforkRule |], + Field [| bvmTxFeePolicy :: Maybe TxFeePolicy |], + Field [| bvmUnlockStakeEpoch :: Maybe EpochIndex |] + ]] + +deriveSimpleBi ''UpdateData [ + Cons 'UpdateData [ + Field [| udAppDiffHash :: Hash Raw |], + Field [| udPkgHash :: Hash Raw |], + Field [| udUpdaterHash :: Hash Raw |], + Field [| udMetadataHash :: Hash Raw |] + ]] + +deriveSimpleBi ''UpdateProposalToSign [ + Cons 'UpdateProposalToSign [ + Field [| upsBV :: BlockVersion |], + Field [| upsBVM :: BlockVersionModifier |], + Field [| upsSV :: SoftwareVersion |], + Field [| upsData :: HashMap SystemTag UpdateData |], + Field [| upsAttr :: UpAttributes |] + ]] + +deriveSimpleBi ''UpdatePayload [ + Cons 'UpdatePayload [ + Field [| upProposal :: Maybe UpdateProposal |], + Field [| upVotes :: [UpdateVote] |] + ]] diff --git a/core/src/Pos/Data/Attributes.hs b/core/src/Pos/Data/Attributes.hs index 06498388f22..6754cd24b73 100644 --- a/core/src/Pos/Data/Attributes.hs +++ b/core/src/Pos/Data/Attributes.hs @@ -76,6 +76,10 @@ instance Buildable (Attributes ()) where ("Attributes { data: (), remain: <"%int%" bytes> }") (unknownAttributesLength attr) +instance Bi (Attributes ()) where + encode = encodeAttributes [] + decode = decodeAttributes () $ \_ _ _ -> pure Nothing + instance Hashable h => Hashable (Attributes h) instance NFData h => NFData (Attributes h) diff --git a/core/src/Pos/Merkle.hs b/core/src/Pos/Merkle.hs index 8a3de5a4961..3d583afa610 100644 --- a/core/src/Pos/Merkle.hs +++ b/core/src/Pos/Merkle.hs @@ -32,7 +32,7 @@ import qualified Data.Foldable as Foldable import qualified Data.Text.Buildable as Buildable import qualified Prelude -import Pos.Binary.Class (Bi, Raw, serializeBuilder) +import Pos.Binary.Class (Bi (..), Raw, serializeBuilder) import Pos.Crypto (AbstractHash (..), Hash, hashRaw) {-# ANN module ("HLint : ignore Unnecessary hiding" :: Text) #-} @@ -45,6 +45,10 @@ newtype MerkleRoot a = MerkleRoot instance Buildable (MerkleRoot a) where build (MerkleRoot h) = "MerkleRoot|" <> Buildable.build h +instance (Bi a, Bi (Hash Raw)) => Bi (MerkleRoot a) where + encode = encode . getMerkleRoot + decode = MerkleRoot <$> decode + -- | Straightforward merkle tree representation in Haskell. data MerkleTree a = MerkleEmpty | MerkleTree Word32 (MerkleNode a) deriving (Eq, Generic) @@ -64,6 +68,12 @@ instance Foldable MerkleTree where instance Show a => Show (MerkleTree a) where show tree = "Merkle tree: " <> show (Foldable.toList tree) +-- This instance is both faster and more space-efficient (as confirmed by a +-- benchmark). Hashing turns out to be faster than decoding extra data. +instance (Bi a, Bi (Hash Raw)) => Bi (MerkleTree a) where + encode = encode . Foldable.toList + decode = mkMerkleTree <$> decode + data MerkleNode a = MerkleBranch { mRoot :: MerkleRoot a , mLeft :: MerkleNode a diff --git a/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs b/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs index 278e4f2c4ed..e9b3bc66ebb 100644 --- a/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs +++ b/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs @@ -15,7 +15,7 @@ module Bench.Pos.Diffusion.BlockDownload where import Universum import Control.Concurrent.STM (readTBQueue) -import Control.DeepSeq (NFData, force) +import Control.DeepSeq (force) import Control.Monad.IO.Class (liftIO) import qualified Criterion import qualified Criterion.Main as Criterion @@ -287,14 +287,6 @@ runBlockDownloadBenchmark :: Criterion.Mode -> NodeId -> (Int -> IO ()) -> Diffu runBlockDownloadBenchmark mode serverAddress setStreamIORef client = Criterion.runMode mode $ blockDownloadBenchmarks serverAddress setStreamIORef client --- It's surprisingly cumbersome to give a non-orphan 'NFData' instance on --- 'BlockHeader', since we have that 'Blockchain' typeclass with a bunch of --- data families. 'BHeaderHash GenesisBlockchain', for instance, must have --- an 'NFData' instance, but in that module we don't yet know that this is --- in fact 'HeaderHash' ~ 'Crypto.Digest Blake2b_256'. --- Anyway, there's a whole saga of pain caused by that silly abstraction. -instance NFData BlockHeader - runBenchmark :: IO () runBenchmark = do {- diff --git a/lib/src/Pos/Binary.hs b/lib/src/Pos/Binary.hs index 6964a100f62..f1562124663 100644 --- a/lib/src/Pos/Binary.hs +++ b/lib/src/Pos/Binary.hs @@ -9,7 +9,6 @@ import Pos.Binary.Class import Pos.Binary.Communication () import Pos.Binary.Core () import Pos.Binary.Delegation () -import Pos.Binary.Merkle () import Pos.Binary.Ssc () import Pos.Binary.Txp () import Pos.Binary.Update ()