diff --git a/cabal.project b/cabal.project index f6c6585a..62f72c60 100644 --- a/cabal.project +++ b/cabal.project @@ -35,22 +35,22 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-base - tag: f869bee9b08ba1044b1476737c9d65083e1c6c7f - --sha256: 0df3bdf13cwx3hd8n4q53g9hybb0w8mh837y64ydd88xhdfaf6a3 + tag: 68dcff6e832efa8711b9757d8ddaba61759da973 + --sha256: 1mqyxi6h2bq4w81v3vn05s0y4i6zp42g6yagy8bzbihh97q2wc0g subdir: binary source-repository-package type: git location: https://github.com/input-output-hk/cardano-base - tag: f869bee9b08ba1044b1476737c9d65083e1c6c7f - --sha256: 0df3bdf13cwx3hd8n4q53g9hybb0w8mh837y64ydd88xhdfaf6a3 + tag: 68dcff6e832efa8711b9757d8ddaba61759da973 + --sha256: 1mqyxi6h2bq4w81v3vn05s0y4i6zp42g6yagy8bzbihh97q2wc0g subdir: cardano-crypto-class source-repository-package type: git location: https://github.com/input-output-hk/cardano-base - tag: f869bee9b08ba1044b1476737c9d65083e1c6c7f - --sha256: 0df3bdf13cwx3hd8n4q53g9hybb0w8mh837y64ydd88xhdfaf6a3 + tag: 68dcff6e832efa8711b9757d8ddaba61759da973 + --sha256: 1mqyxi6h2bq4w81v3vn05s0y4i6zp42g6yagy8bzbihh97q2wc0g subdir: binary/test source-repository-package diff --git a/cardano-ledger/bench/Benchmarks.hs b/cardano-ledger/bench/Benchmarks.hs new file mode 100644 index 00000000..540bde0f --- /dev/null +++ b/cardano-ledger/bench/Benchmarks.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +module Main (main) where + +import Cardano.Chain.Common +import Cardano.Chain.UTxO +import Cardano.Crypto.Signing (VerificationKey, SigningKey) +import Cardano.Crypto.Signing.Safe (PassPhrase(..), safeDeterministicKeyGen) + +import Criterion.Main + +main :: IO () +main = + defaultMain [ + bgroup "CompactUTxO" [ + bench "toCompactTxId" $ whnf toCompactTxId exampleTxId + , bench "fromCompactTxId" $ whnf fromCompactTxId exampleCompactTxId + + , bench "toCompactTxIn" $ whnf toCompactTxIn exampleTxIn + , bench "fromCompactTxIn" $ whnf fromCompactTxIn exampleCompactTxIn + + , bench "toCompactAddress" $ whnf toCompactAddress exampleAddress + , bench "fromCompactAddress" $ whnf fromCompactAddress exampleCompactAddress + + , bench "toCompactTxOut" $ whnf toCompactTxOut exampleTxOut + , bench "fromCompactTxOut" $ whnf fromCompactTxOut exampleCompactTxOut + ] + ] + +-- +-- Tx Inputs +-- + +exampleTxId :: TxId +exampleTxId = "ee155ace9c40292074cb6aff8c9ccdd273c81648ff1149ef36bcea6ebb8a3e25" + +exampleCompactTxId :: CompactTxId +exampleCompactTxId = toCompactTxId exampleTxId + + +exampleTxIn :: TxIn +exampleTxIn = TxInUtxo exampleTxId 42 + +exampleCompactTxIn :: CompactTxIn +exampleCompactTxIn = toCompactTxIn exampleTxIn + +-- +-- Tx Outputs +-- + +exampleAddress :: Address +exampleAddress = makeAddress (VerKeyASD exampleVKey) examplAttrs + +exampleCompactAddress :: CompactAddress +exampleCompactAddress = toCompactAddress exampleAddress + +exampleTxOut :: TxOut +exampleTxOut = + TxOut { + txOutAddress = exampleAddress + , txOutValue = mkKnownLovelace @42424242 + } + where + +exampleCompactTxOut :: CompactTxOut +exampleCompactTxOut = toCompactTxOut exampleTxOut + + +exampleVKey :: VerificationKey +exampleSKey :: SigningKey +(exampleVKey, exampleSKey) = + safeDeterministicKeyGen + "example salt of at least 32 bytes length" + (PassPhrase "example secret passphrase") + +examplAttrs :: AddrAttributes +examplAttrs = + AddrAttributes { + aaNetworkMagic = NetworkMainOrStage + , aaVKDerivationPath = Just payload + } + where + payload = HDAddressPayload "a legacy Byron Daedalus HD address payload" diff --git a/cardano-ledger/cardano-ledger.cabal b/cardano-ledger/cardano-ledger.cabal index 500729ba..7a007f27 100644 --- a/cardano-ledger/cardano-ledger.cabal +++ b/cardano-ledger/cardano-ledger.cabal @@ -152,6 +152,7 @@ library , megaparsec , memory , mtl + , primitive , resourcet , streaming , streaming-binary @@ -288,6 +289,7 @@ test-suite cardano-ledger-test -fno-warn-safe -fno-warn-unsafe "-with-rtsopts=-K5M -M500M" + -threaded if (!flag(development)) ghc-options: -Werror @@ -339,3 +341,14 @@ test-suite epoch-validation-normal-form-test if (!flag(development)) ghc-options: -Werror + +benchmark cardano-ledger-bench + hs-source-dirs: bench + main-is: Benchmarks.hs + type: exitcode-stdio-1.0 + build-depends: base + , cardano-crypto-wrapper + , cardano-ledger + , criterion + default-language: Haskell2010 + diff --git a/cardano-ledger/src/Cardano/Chain/Common/Address.hs b/cardano-ledger/src/Cardano/Chain/Common/Address.hs index 352d696c..ce586578 100644 --- a/cardano-ledger/src/Cardano/Chain/Common/Address.hs +++ b/cardano-ledger/src/Cardano/Chain/Common/Address.hs @@ -35,7 +35,6 @@ module Cardano.Chain.Common.Address -- * Utilities , addrAttributesUnwrapped , addrNetworkMagic - , unAddressHash -- * Pattern-matching helpers , isRedeemAddress @@ -50,8 +49,6 @@ where import Cardano.Prelude -import qualified Data.ByteArray - import Control.Monad.Except (MonadError) import qualified Data.Aeson as Aeson import Data.ByteString.Base58 @@ -110,10 +107,6 @@ instance FromCBOR Address' where matchSize "Address'" 3 len fmap Address' $ (,,) <$> fromCBOR <*> fromCBOR <*> fromCBOR --- | Get the ByteString of the hash. -unAddressHash :: AddressHash Address' -> ByteString -unAddressHash = Data.ByteArray.convert - -- | 'Address' is where you can send Lovelace data Address = Address { addrRoot :: !(AddressHash Address') diff --git a/cardano-ledger/src/Cardano/Chain/Common/AddressHash.hs b/cardano-ledger/src/Cardano/Chain/Common/AddressHash.hs index e6bafa20..a9741fd6 100644 --- a/cardano-ledger/src/Cardano/Chain/Common/AddressHash.hs +++ b/cardano-ledger/src/Cardano/Chain/Common/AddressHash.hs @@ -2,22 +2,27 @@ module Cardano.Chain.Common.AddressHash ( AddressHash , addressHash , unsafeAddressHash + , addressHashSize ) where +import qualified Prelude import Cardano.Prelude import Crypto.Hash (Blake2b_224, Digest, SHA3_256) import qualified Crypto.Hash as CryptoHash import Cardano.Binary (ToCBOR, serialize) -import Cardano.Crypto.Hashing (AbstractHash(..)) +import Cardano.Crypto.Hashing (AbstractHash, abstractHashFromDigest) -- | Hash used to identify address. type AddressHash = AbstractHash Blake2b_224 +addressHashSize :: Int +addressHashSize = CryptoHash.hashDigestSize (Prelude.undefined :: Blake2b_224) + unsafeAddressHash :: ToCBOR a => a -> AddressHash b -unsafeAddressHash = AbstractHash . secondHash . firstHash +unsafeAddressHash = abstractHashFromDigest . secondHash . firstHash where firstHash :: ToCBOR a => a -> Digest SHA3_256 firstHash = CryptoHash.hashlazy . serialize diff --git a/cardano-ledger/src/Cardano/Chain/Common/Compact.hs b/cardano-ledger/src/Cardano/Chain/Common/Compact.hs index 5f7392c5..e2b3152a 100644 --- a/cardano-ledger/src/Cardano/Chain/Common/Compact.hs +++ b/cardano-ledger/src/Cardano/Chain/Common/Compact.hs @@ -4,6 +4,8 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} module Cardano.Chain.Common.Compact ( CompactAddress @@ -15,10 +17,19 @@ where import Cardano.Prelude import Cardano.Binary (FromCBOR(..), ToCBOR(..), serialize', decodeFull') -import qualified Data.ByteString.Short as BSS (fromShort, toShort) -import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as SBS +import Data.ByteString.Short (ShortByteString) +import qualified Data.Map.Strict as Map +import Control.Monad.Fail (MonadFail(fail)) -import Cardano.Chain.Common.Address (Address(..)) +import Cardano.Crypto.Hashing +import Cardano.Chain.Common.Address (Address(..), Address') +import Cardano.Chain.Common.AddressHash (AddressHash, addressHashSize) +import Cardano.Chain.Common.Attributes (Attributes(..), UnparsedFields(..)) +import Cardano.Chain.Common.AddrAttributes (AddrAttributes(..), HDAddressPayload(..)) +import Cardano.Chain.Common.AddrSpendingData (AddrType(..)) +import Cardano.Chain.Common.NetworkMagic (NetworkMagic(..)) -------------------------------------------------------------------------------- -- Compact Address @@ -28,24 +39,138 @@ import Cardano.Chain.Common.Address (Address(..)) -- -- Convert using 'toCompactAddress' and 'fromCompactAddress'. -- -newtype CompactAddress = CompactAddress ShortByteString +data CompactAddress = + CAMainnet {-# UNPACK #-} !ShortByteString + | CAMainnetAttrs {-# UNPACK #-} !ShortByteString + !UnparsedFields + | CAMainnetRedeem {-# UNPACK #-} !ShortByteString + !UnparsedFields + | CATestnet {-# UNPACK #-} !ShortByteString + {-# UNPACK #-} !Word32 + | CATestnetAttrs {-# UNPACK #-} !ShortByteString + {-# UNPACK #-} !Word32 + !UnparsedFields + | CATestnetRedeem {-# UNPACK #-} !ShortByteString + {-# UNPACK #-} !Word32 + !UnparsedFields + deriving (Eq, Ord, Generic, Show) - deriving newtype HeapWords deriving anyclass NFData - deriving NoUnexpectedThunks via UseIsNormalForm ShortByteString + deriving anyclass NoUnexpectedThunks + +instance HeapWords CompactAddress where + heapWords (CAMainnet payload) = 1 + heapWordsUnpacked payload + heapWords (CAMainnetAttrs payload attrs) = 1 + heapWordsUnpacked payload + + heapWords attrs + heapWords (CAMainnetRedeem payload attrs) = 1 + heapWordsUnpacked payload + + heapWords attrs + heapWords (CATestnet payload _) = 2 + heapWordsUnpacked payload + heapWords (CATestnetAttrs payload _ attrs) = 2 + heapWordsUnpacked payload + + heapWords attrs + heapWords (CATestnetRedeem payload _ attrs) = 2 + heapWordsUnpacked payload + + heapWords attrs instance FromCBOR CompactAddress where - fromCBOR = CompactAddress . BSS.toShort <$> fromCBOR + fromCBOR = do + bs <- fromCBOR + case decodeFull' bs of + Left err -> fail (show err) + Right decAddr -> return $! toCompactAddress decAddr instance ToCBOR CompactAddress where - toCBOR (CompactAddress sbs) = toCBOR (BSS.fromShort sbs) + toCBOR = toCBOR . serialize' . fromCompactAddress toCompactAddress :: Address -> CompactAddress -toCompactAddress addr = - CompactAddress (BSS.toShort (serialize' addr)) +toCompactAddress Address { + addrRoot + , addrType + , addrAttributes = + Attributes { + attrData = + AddrAttributes { + aaNetworkMagic + , aaVKDerivationPath + } + , attrRemain = attrs@(UnparsedFields attrsMap) + } + } = + let !payload = toCompactAddressPayload addrRoot aaVKDerivationPath in + case (aaNetworkMagic, addrType) of + (NetworkMainOrStage, ATVerKey) + | Map.null attrsMap -> CAMainnet payload + | otherwise -> CAMainnetAttrs payload attrs + (NetworkMainOrStage, ATRedeem) -> CAMainnetRedeem payload attrs + (NetworkTestnet magic, ATVerKey) + | Map.null attrsMap -> CATestnet payload magic + | otherwise -> CATestnetAttrs payload magic attrs + (NetworkTestnet magic, ATRedeem) -> CATestnetRedeem payload magic attrs fromCompactAddress :: CompactAddress -> Address -fromCompactAddress (CompactAddress addr) = - case decodeFull' (BSS.fromShort addr) of - Left err -> panic ("fromCompactAddress: impossible: " <> show err) - Right decAddr -> decAddr +fromCompactAddress (CAMainnet payload) = + mkAddress NetworkMainOrStage ATVerKey attrs addrRoot aaVKDerivationPath + where + (addrRoot, aaVKDerivationPath) = fromCompactAddressPayload payload + attrs = UnparsedFields Map.empty + +fromCompactAddress (CAMainnetAttrs payload attrs) = + mkAddress NetworkMainOrStage ATVerKey attrs addrRoot aaVKDerivationPath + where + (addrRoot, aaVKDerivationPath) = fromCompactAddressPayload payload + +fromCompactAddress (CAMainnetRedeem payload attrs) = + mkAddress NetworkMainOrStage ATRedeem attrs addrRoot aaVKDerivationPath + where + (addrRoot, aaVKDerivationPath) = fromCompactAddressPayload payload + +fromCompactAddress (CATestnet payload magic) = + mkAddress (NetworkTestnet magic) ATVerKey attrs addrRoot aaVKDerivationPath + where + (addrRoot, aaVKDerivationPath) = fromCompactAddressPayload payload + attrs = UnparsedFields Map.empty + +fromCompactAddress (CATestnetAttrs payload magic attrs) = + mkAddress (NetworkTestnet magic) ATVerKey attrs addrRoot aaVKDerivationPath + where + (addrRoot, aaVKDerivationPath) = fromCompactAddressPayload payload + +fromCompactAddress (CATestnetRedeem payload magic attrs) = + mkAddress (NetworkTestnet magic) ATRedeem attrs addrRoot aaVKDerivationPath + where + (addrRoot, aaVKDerivationPath) = fromCompactAddressPayload payload + +mkAddress !aaNetworkMagic !addrType !attrRemain !addrRoot !aaVKDerivationPath = + Address { + addrRoot + , addrType + , addrAttributes = + Attributes { + attrData = AddrAttributes { + aaNetworkMagic + , aaVKDerivationPath + } + , attrRemain + } + } + + +toCompactAddressPayload :: AddressHash Address' + -> Maybe HDAddressPayload + -> ShortByteString +toCompactAddressPayload addr Nothing = + abstractHashToBytesShort addr + +toCompactAddressPayload addr (Just (HDAddressPayload hd)) = + abstractHashToBytesShort addr <> SBS.toShort hd + +fromCompactAddressPayload :: ShortByteString + -> (AddressHash Address', Maybe HDAddressPayload) +fromCompactAddressPayload payload = + (addr', hd') + where + addr' :: AddressHash Address' + !addr' = unsafeAbstractHashFromBytes addr + !hd' | BS.null hd = Nothing + | otherwise = Just (HDAddressPayload hd) + + (addr, hd) = BS.splitAt addressHashSize (SBS.fromShort payload) + diff --git a/cardano-ledger/src/Cardano/Chain/Common/Merkle.hs b/cardano-ledger/src/Cardano/Chain/Common/Merkle.hs index 4f573a71..8cd8ead0 100644 --- a/cardano-ledger/src/Cardano/Chain/Common/Merkle.hs +++ b/cardano-ledger/src/Cardano/Chain/Common/Merkle.hs @@ -40,7 +40,6 @@ import Cardano.Prelude import Data.Aeson (ToJSON) import Data.Bits (Bits(..)) -import Data.ByteArray (ByteArrayAccess, convert) import Data.ByteString.Builder (Builder, byteString, word8) import qualified Data.ByteString.Builder.Extra as Builder import qualified Data.ByteString.Lazy as LBS @@ -51,7 +50,7 @@ import qualified Prelude import Cardano.Binary (Annotated(..), FromCBOR(..), Raw, ToCBOR(..), serializeBuilder) -import Cardano.Crypto (AbstractHash(..), Hash, hashDecoded, hashRaw) +import Cardano.Crypto (Hash, hashDecoded, hashRaw, hashToBytes) -------------------------------------------------------------------------------- @@ -62,7 +61,6 @@ import Cardano.Crypto (AbstractHash(..), Hash, hashDecoded, hashRaw) newtype MerkleRoot a = MerkleRoot { getMerkleRoot :: Hash Raw -- ^ returns root 'Hash' of Merkle Tree } deriving (Show, Eq, Ord, Generic) - deriving newtype ByteArrayAccess deriving anyclass (NFData, NoUnexpectedThunks) instance Buildable (MerkleRoot a) where @@ -79,7 +77,7 @@ instance FromCBOR a => FromCBOR (MerkleRoot a) where fromCBOR = MerkleRoot <$> fromCBOR merkleRootToBuilder :: MerkleRoot a -> Builder -merkleRootToBuilder (MerkleRoot (AbstractHash d)) = byteString (convert d) +merkleRootToBuilder (MerkleRoot h) = byteString (hashToBytes h) mkRoot :: MerkleRoot a -> MerkleRoot a -> MerkleRoot a mkRoot a b = MerkleRoot . hashRaw . toLazyByteString $ mconcat diff --git a/cardano-ledger/src/Cardano/Chain/UTxO/Compact.hs b/cardano-ledger/src/Cardano/Chain/UTxO/Compact.hs index 2d44dbf5..2f3be1e2 100644 --- a/cardano-ledger/src/Cardano/Chain/UTxO/Compact.hs +++ b/cardano-ledger/src/Cardano/Chain/UTxO/Compact.hs @@ -33,12 +33,11 @@ where import Cardano.Prelude -import Crypto.Hash (digestFromByteString) -import Cardano.Crypto.Hashing (AbstractHash(..)) -import Data.Binary.Get (Get, getWord64le, runGet) -import Data.Binary.Put (Put, putWord64le, runPut) -import qualified Data.ByteArray as BA (convert) -import qualified Data.ByteString.Lazy as BSL (fromStrict, toStrict) +import Cardano.Crypto.Hashing (hashToBytesShort, unsafeHashFromBytesShort) +import qualified Data.ByteString.Short.Internal as SBS +import Data.Primitive.PrimArray + ( PrimArray(..), indexPrimArray, newPrimArray + , writePrimArray, unsafeFreezePrimArray ) import Cardano.Binary (FromCBOR(..), ToCBOR(..), encodeListLen, enforceSize) import Cardano.Chain.Common.Compact @@ -156,30 +155,41 @@ instance ToCBOR CompactTxId where <> toCBOR c <> toCBOR d -getCompactTxId :: Get CompactTxId -getCompactTxId = - CompactTxId <$> getWord64le - <*> getWord64le - <*> getWord64le - <*> getWord64le - -putCompactTxId :: CompactTxId -> Put -putCompactTxId (CompactTxId a b c d) = - putWord64le a >> putWord64le b - >> putWord64le c - >> putWord64le d - toCompactTxId :: TxId -> CompactTxId -toCompactTxId txId = - let bs = BA.convert txId :: ByteString - in runGet getCompactTxId (BSL.fromStrict bs) +toCompactTxId txid = + -- This is a little bit cunning. We extract the ByteArray# from the + -- ShortByteString representation of the TxId Hash, and using the primitive + -- package we make a PrimArray Word64 which we can then use to read the + -- four words. So this should mean the cost is just 4 memory reads & writes. + CompactTxId + (indexPrimArray arr 0) + (indexPrimArray arr 1) + (indexPrimArray arr 2) + (indexPrimArray arr 3) + where + arr :: PrimArray Word64 + arr = toPrimArray (hashToBytesShort txid) + + toPrimArray :: SBS.ShortByteString -> PrimArray Word64 + toPrimArray (SBS.SBS ba) = PrimArray ba fromCompactTxId :: CompactTxId -> TxId -fromCompactTxId compactTxId = - let bs = BSL.toStrict $ runPut (putCompactTxId compactTxId) - in case digestFromByteString bs of - Just d -> AbstractHash d - Nothing -> panic "fromCompactTxId: impossible: failed to reconstruct TxId from CompactTxId" +fromCompactTxId (CompactTxId w0 w1 w2 w3) = + unsafeHashFromBytesShort + . fromPrimArray + $ runST mkByteArray + where + mkByteArray :: ST s (PrimArray Word64) + mkByteArray = do + arr <- newPrimArray 4 + writePrimArray arr 0 w0 + writePrimArray arr 1 w1 + writePrimArray arr 2 w2 + writePrimArray arr 3 w3 + unsafeFreezePrimArray arr + + fromPrimArray :: PrimArray Word64 -> SBS.ShortByteString + fromPrimArray (PrimArray ba) = SBS.SBS ba -------------------------------------------------------------------------------- -- Compact TxOut @@ -189,7 +199,7 @@ fromCompactTxId compactTxId = -- -- Convert using 'toCompactTxOut' and 'fromCompactTxOut'. -- -data CompactTxOut = CompactTxOut {-# UNPACK #-} !CompactAddress +data CompactTxOut = CompactTxOut !CompactAddress {-# UNPACK #-} !Lovelace deriving (Eq, Ord, Generic, Show) deriving anyclass (NFData, NoUnexpectedThunks) diff --git a/cardano-ledger/src/Cardano/Chain/UTxO/Tx.hs b/cardano-ledger/src/Cardano/Chain/UTxO/Tx.hs index c03ee320..bc94b721 100644 --- a/cardano-ledger/src/Cardano/Chain/UTxO/Tx.hs +++ b/cardano-ledger/src/Cardano/Chain/UTxO/Tx.hs @@ -127,7 +127,7 @@ type TxAttributes = Attributes () data TxIn -- | TxId = Which transaction's output is used -- | Word32 = Index of the output in transaction's outputs - = TxInUtxo TxId Word32 + = TxInUtxo !TxId !Word32 deriving (Eq, Ord, Generic, Show) deriving anyclass NFData diff --git a/cardano-ledger/test/Test/Cardano/Chain/Common/CBOR.hs b/cardano-ledger/test/Test/Cardano/Chain/Common/CBOR.hs index d0ed8bf3..9771f382 100644 --- a/cardano-ledger/test/Test/Cardano/Chain/Common/CBOR.hs +++ b/cardano-ledger/test/Test/Cardano/Chain/Common/CBOR.hs @@ -63,6 +63,7 @@ import Test.Cardano.Chain.Common.Gen , genAddrSpendingData , genAddrType , genAttributes + , genAttributesNoUnparsedFields , genBlockCount , genChainDifficulty , genLovelace @@ -316,11 +317,11 @@ sizeEstimates = [ ("Lovelace" , check genLovelace) , ("BlockCount" , check genBlockCount) , ("Attributes ()" , sizeTest $ scfg - { gen = genAttributes (pure ()) + { gen = genAttributesNoUnparsedFields (pure ()) , addlCtx = M.fromList [ attrUnitSize ] }) , ("Attributes AddrAttributes", sizeTest $ scfg - { gen = genAttributes genAddrAttributes + { gen = genAttributesNoUnparsedFields genAddrAttributes , addlCtx = M.fromList [ attrAddrSize ] }) , ("Address" , sizeTest $ scfg diff --git a/cardano-ledger/test/Test/Cardano/Chain/Common/Gen.hs b/cardano-ledger/test/Test/Cardano/Chain/Common/Gen.hs index a37707b4..8a58f460 100644 --- a/cardano-ledger/test/Test/Cardano/Chain/Common/Gen.hs +++ b/cardano-ledger/test/Test/Cardano/Chain/Common/Gen.hs @@ -10,6 +10,7 @@ module Test.Cardano.Chain.Common.Gen , genAddrType , genAddrSpendingData , genAttributes + , genAttributesNoUnparsedFields , genBlockCount , genCanonicalTxFeePolicy , genChainDifficulty @@ -30,6 +31,8 @@ module Test.Cardano.Chain.Common.Gen where import Cardano.Prelude +import Data.ByteString.Lazy as LBS +import qualified Data.Map as Map import Test.Cardano.Prelude (gen32Bytes) import Formatting (build, sformat) @@ -45,7 +48,8 @@ import Cardano.Chain.Common , AddrSpendingData(..) , AddrType(..) , Address(..) - , Attributes + , Address'(..) + , Attributes(..) , BlockCount(..) , ChainDifficulty(..) , CompactAddress @@ -58,10 +62,11 @@ import Cardano.Chain.Common , KeyHash , TxFeePolicy(..) , TxSizeLinear(..) + , UnparsedFields(..) + , addressHash + , addrSpendingDataToType , rationalToLovelacePortion - , makeAddress , maxLovelaceVal - , mkAttributes , mkLovelace , mkMerkleTree , hashKey @@ -83,11 +88,27 @@ genHDAddressPayload :: Gen HDAddressPayload genHDAddressPayload = HDAddressPayload <$> gen32Bytes genAddress :: Gen Address -genAddress = makeAddress <$> genAddrSpendingData <*> genAddrAttributes +genAddress = makeAddress <$> genAddrSpendingData + <*> genAddrAttributes + <*> genUnparsedFields genAddressWithNM :: NetworkMagic -> Gen Address genAddressWithNM nm = makeAddress <$> genAddrSpendingData <*> genAddrAttributesWithNM nm + <*> genUnparsedFields + +-- The normal makeAddress does not let one specify the UnparsedFields +makeAddress :: AddrSpendingData -> AddrAttributes -> UnparsedFields -> Address +makeAddress spendingData attributesUnwrapped unparsedFields = + Address { + addrRoot = addressHash address' + , addrAttributes = attributes + , addrType = addrType' + } + where + addrType' = addrSpendingDataToType spendingData + attributes = Attributes attributesUnwrapped unparsedFields + address' = Address' (addrType', spendingData, attributes) genAddrType :: Gen AddrType genAddrType = Gen.choice [pure ATVerKey, pure ATRedeem] @@ -97,7 +118,12 @@ genAddrSpendingData = Gen.choice [VerKeyASD <$> genVerificationKey, RedeemASD <$> genRedeemVerificationKey] genAttributes :: Gen a -> Gen (Attributes a) -genAttributes genA = mkAttributes <$> genA +genAttributes genA = Attributes <$> genA <*> genUnparsedFields + +-- | Same as 'genAttributes' but do not include any extra 'UnparsedFields'. +genAttributesNoUnparsedFields :: Gen a -> Gen (Attributes a) +genAttributesNoUnparsedFields genA = + Attributes <$> genA <*> pure (UnparsedFields Map.empty) genBlockCount :: Gen BlockCount genBlockCount = BlockCount <$> Gen.word64 Range.constantBounded @@ -200,3 +226,13 @@ genTxSizeLinear = TxSizeLinear <$> genLovelace <*> genMultiplier -- | Generate multipliers for the TxSizeLinear. genMultiplier :: Gen Rational genMultiplier = fromIntegral <$> Gen.word16 (Range.constant 0 1000) + +genUnparsedFields :: Gen UnparsedFields +genUnparsedFields = UnparsedFields <$> Gen.map (Range.linear 0 5) + genUnparsedField + where + -- Range of unparsed attrs has to be 3 or above, 1 and 2 are known attrs + genUnparsedField :: Gen (Word8, LBS.ByteString) + genUnparsedField = (,) <$> Gen.word8 (Range.constant 3 255) + <*> (LBS.fromStrict <$> Gen.bytes (Range.linear 0 10)) + diff --git a/cardano-ledger/test/Test/Cardano/Chain/UTxO/Example.hs b/cardano-ledger/test/Test/Cardano/Chain/UTxO/Example.hs index 30b82410..606fa440 100644 --- a/cardano-ledger/test/Test/Cardano/Chain/UTxO/Example.hs +++ b/cardano-ledger/test/Test/Cardano/Chain/UTxO/Example.hs @@ -55,8 +55,7 @@ import Cardano.Chain.UTxO , mkTxPayload ) import Cardano.Crypto - ( AbstractHash(..) - , Hash + ( Hash , ProtocolMagicId(..) , VerificationKey(..) , RedeemSignature diff --git a/crypto/src/Cardano/Crypto/Hashing.hs b/crypto/src/Cardano/Crypto/Hashing.hs index be082530..87214eb2 100644 --- a/crypto/src/Cardano/Crypto/Hashing.hs +++ b/crypto/src/Cardano/Crypto/Hashing.hs @@ -15,25 +15,39 @@ -- | Hashing capabilities. module Cardano.Crypto.Hashing - ( -- * AbstractHash - AbstractHash(..) - , decodeAbstractHash - , decodeHash + ( -- * 'AbstractHash' type supporting different hash algorithms + AbstractHash + , HashAlgorithm + -- ** Hashing , abstractHash , unsafeAbstractHash + -- ** Conversion + , abstractHashFromDigest + , abstractHashFromBytes + , unsafeAbstractHashFromBytes + , unsafeAbstractHashFromBytesShort + , abstractHashToBytes + , abstractHashToBytesShort + -- ** Parsing and printing + , decodeAbstractHash - -- * Common Hash + -- * Standard 'Hash' type using Blake2b 256 , Hash - , hashHexF - , mediumHashF - , shortHashF + -- ** Hashing , hash , hashDecoded , hashRaw - - -- * Utility - , HashAlgorithm - , hashDigestSize' + -- ** Conversion + , hashFromBytes + , unsafeHashFromBytes + , unsafeHashFromBytesShort + , hashToBytes + , hashToBytesShort + -- ** Parsing and printing + , decodeHash + , hashHexF + , mediumHashF + , shortHashF ) where @@ -51,8 +65,13 @@ import Data.Aeson ) import Data.Aeson.Types (toJSONKeyText) import qualified Data.ByteArray as ByteArray +import qualified Data.ByteArray.Encoding as ByteArray import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Short as SBS +import qualified Data.Text as Text +import Data.String (IsString(..)) import Formatting (Format, bprint, build, fitLeft, later, sformat, (%.)) import qualified Formatting.Buildable as B (Buildable(..)) @@ -74,17 +93,28 @@ import Cardano.Binary -- | Hash wrapper with phantom type for more type-safety -- -- Made abstract in order to support different algorithms -newtype AbstractHash algo a = - AbstractHash (Digest algo) - deriving (Show, Eq, Ord, ByteArray.ByteArrayAccess, Generic, NFData) - deriving NoUnexpectedThunks via UseIsNormalForm (Digest algo) +newtype AbstractHash algo a = AbstractHash SBS.ShortByteString + deriving (Eq, Ord, Generic, NFData) + deriving NoUnexpectedThunks via UseIsNormalForm SBS.ShortByteString + +instance Show (AbstractHash algo a) where + show (AbstractHash h) = BSC.unpack + . ByteArray.convertToBase ByteArray.Base16 + . SBS.fromShort + $ h + +instance HashAlgorithm algo => IsString (AbstractHash algo a) where + fromString s = + case decodeAbstractHash (Text.pack s) of + Right h -> h + Left _ -> panic ("AbstractHash.fromString: invalid hash: " <> show s) instance HashAlgorithm algo => Read (AbstractHash algo a) where readsPrec _ s = case parseBase16 $ toS s of Left _ -> [] - Right bs -> case Hash.digestFromByteString bs of + Right bs -> case abstractHashFromBytes bs of Nothing -> [] - Just h -> [(AbstractHash h, "")] + Just h -> [(h, "")] instance B.Buildable (AbstractHash algo a) where build = bprint mediumHashF @@ -103,45 +133,42 @@ instance ToJSONKey (AbstractHash algo a) where toJSONKey = toJSONKeyText (sformat hashHexF) instance (Typeable algo, Typeable a, HashAlgorithm algo) => ToCBOR (AbstractHash algo a) where - toCBOR (AbstractHash digest) = - toCBOR (ByteArray.convert digest :: BS.ByteString) + toCBOR (AbstractHash h) = toCBOR h encodedSizeExpr _ _ = let realSz = hashDigestSize (panic "unused, I hope!" :: algo) in fromInteger (toInteger (withWordSize realSz + realSz)) -instance (Typeable algo, Typeable a, HashAlgorithm algo) => FromCBOR (AbstractHash algo a) where +instance (Typeable algo, Typeable a, HashAlgorithm algo) + => FromCBOR (AbstractHash algo a) where + fromCBOR = do -- FIXME bad decode: it reads an arbitrary-length byte string. -- Better instance: know the hash algorithm up front, read exactly that -- many bytes, fail otherwise. Then convert to a digest. - fromCBOR = do - bs <- fromCBOR @ByteString - maybe - (cborError $ DecoderErrorCustom - "AbstractHash" - "Cannot convert ByteString to digest" - ) - (pure . AbstractHash) - (Hash.digestFromByteString bs) + bs <- fromCBOR @SBS.ShortByteString + when (SBS.length bs /= expectedSize) $ + cborError $ DecoderErrorCustom "AbstractHash" "Bytes not expected length" + return (AbstractHash bs) + where + expectedSize = hashDigestSize (Prelude.undefined :: algo) instance HeapWords (AbstractHash algo a) where heapWords _ -- We have -- - -- > newtype AbstractHash algo a = AbstractHash (Digest algo) - -- > newtype Digest a = Digest (Block Word8) - -- > data Block ty = Block ByteArray# + -- > newtype AbstractHash algo a = AbstractHash ShortByteString + -- > data ShortByteString = SBS ByteArray# -- -- so @AbstractHash algo a@ requires: -- - -- - 1 word for the 'Block' object header + -- - 1 word for the 'ShortByteString' object header -- - 1 word for the pointer to the byte array object -- - 1 word for the byte array object header -- - 1 word for the size of the byte array payload in bytes -- - 4 words (on a 64-bit arch) for the byte array payload containing the digest -- -- +---------+ - -- │Block│ * │ + -- │ SBS │ * │ -- +-------+-+ -- | -- v @@ -151,64 +178,110 @@ instance HeapWords (AbstractHash algo a) where -- = 8 -hashDigestSize' :: forall algo . HashAlgorithm algo => Int -hashDigestSize' = hashDigestSize @algo - (panic - "Cardano.Crypto.Hashing.hashDigestSize': HashAlgorithm value is evaluated!" - ) - -- | Parses given hash in base16 form. decodeAbstractHash :: HashAlgorithm algo => Text -> Either Text (AbstractHash algo a) decodeAbstractHash prettyHash = do bytes <- first (sformat build) $ parseBase16 prettyHash - case Hash.digestFromByteString bytes of + case abstractHashFromBytes bytes of Nothing -> Left ( "decodeAbstractHash: " <> "can't convert bytes to hash," <> " the value was " <> toS prettyHash ) - Just digest -> return (AbstractHash digest) - --- | Parses given hash in base16 form. -decodeHash :: Text -> Either Text (Hash a) -decodeHash = decodeAbstractHash @Blake2b_256 + Just h -> return h -- | Hash the 'ToCBOR'-serialised version of a value abstractHash :: (HashAlgorithm algo, ToCBOR a) => a -> AbstractHash algo a abstractHash = unsafeAbstractHash . serialize --- | Make an 'AbstractHash' from a lazy 'ByteString' +-- | Hash a lazy 'LByteString' +-- +-- You can choose the phantom type, hence the \"unsafe\". +unsafeAbstractHash :: HashAlgorithm algo => LByteString -> AbstractHash algo a +unsafeAbstractHash = abstractHashFromDigest . Hash.hashlazy + +-- | Make an 'AbstractHash' from a 'Digest' for the same 'HashAlgorithm'. +-- +abstractHashFromDigest :: Digest algo -> AbstractHash algo a +abstractHashFromDigest = AbstractHash . SBS.toShort . ByteArray.convert + +-- | Make an 'AbstractHash' from the bytes representation of the hash. It will +-- fail if given the wrong number of bytes for the choice of 'HashAlgorithm'. -- --- You can choose the phantom type, hence the "unsafe" -unsafeAbstractHash - :: HashAlgorithm algo => LByteString -> AbstractHash algo anything -unsafeAbstractHash = AbstractHash . Hash.hashlazy +abstractHashFromBytes :: forall algo a. HashAlgorithm algo + => ByteString -> Maybe (AbstractHash algo a) +abstractHashFromBytes bs + | BS.length bs == expectedSize = Just (unsafeAbstractHashFromBytes bs) + | otherwise = Nothing + where + expectedSize = hashDigestSize (Prelude.undefined :: algo) + +-- | Like 'abstractHashFromDigestBytes' but the number of bytes provided +-- /must/ be correct for the choice of 'HashAlgorithm'. +-- +unsafeAbstractHashFromBytes :: ByteString -> AbstractHash algo a +unsafeAbstractHashFromBytes = AbstractHash . SBS.toShort + +unsafeAbstractHashFromBytesShort :: SBS.ShortByteString -> AbstractHash algo a +unsafeAbstractHashFromBytesShort = AbstractHash + +-- | The bytes representation of the hash value. +-- +abstractHashToBytes :: AbstractHash algo a -> ByteString +abstractHashToBytes (AbstractHash h) = SBS.fromShort h + +abstractHashToBytesShort :: AbstractHash algo a -> SBS.ShortByteString +abstractHashToBytesShort (AbstractHash h) = h -------------------------------------------------------------------------------- -- Hash -------------------------------------------------------------------------------- --- | Type alias for commonly used hash +-- | The type of our commonly used hash, Blake2b 256 type Hash = AbstractHash Blake2b_256 --- | Short version of 'unsafeHash'. +-- | The hash of a value, serialised via 'ToCBOR'. hash :: ToCBOR a => a -> Hash a hash = abstractHash --- | Hashes the annotation +-- | The hash of a value's annotation hashDecoded :: (Decoded t) => t -> Hash (BaseType t) hashDecoded = unsafeAbstractHash . LBS.fromStrict . recoverBytes --- | Raw constructor application. +-- | Hash a bytestring hashRaw :: LBS.ByteString -> Hash Raw hashRaw = unsafeAbstractHash +-- | Make a hash from it bytes representation. It must be a 32-byte bytestring. +-- The size is checked. +hashFromBytes :: ByteString -> Maybe (Hash a) +hashFromBytes = abstractHashFromBytes + +-- | Make a hash from a 32-byte bytestring. It must be exactly 32 bytes. +unsafeHashFromBytes :: ByteString -> Hash a +unsafeHashFromBytes = unsafeAbstractHashFromBytes + +unsafeHashFromBytesShort :: SBS.ShortByteString -> Hash a +unsafeHashFromBytesShort = unsafeAbstractHashFromBytesShort + +-- | The bytes representation of the hash value. +-- +hashToBytes :: AbstractHash algo a -> ByteString +hashToBytes = abstractHashToBytes + +hashToBytesShort :: AbstractHash algo a -> SBS.ShortByteString +hashToBytesShort = abstractHashToBytesShort + +-- | Parses given hash in base16 form. +decodeHash :: Text -> Either Text (Hash a) +decodeHash = decodeAbstractHash @Blake2b_256 + -- | Specialized formatter for 'Hash'. hashHexF :: Format r (AbstractHash algo a -> r) -hashHexF = later $ \(AbstractHash x) -> B.build (show x :: Text) +hashHexF = later $ \h -> B.build (show h :: Text) -- | Smart formatter for 'Hash' to show only first @16@ characters of 'Hash'. mediumHashF :: Format r (AbstractHash algo a -> r) diff --git a/crypto/test/Test/Cardano/Crypto/Gen.hs b/crypto/test/Test/Cardano/Crypto/Gen.hs index 67fbd1c1..41842903 100644 --- a/crypto/test/Test/Cardano/Crypto/Gen.hs +++ b/crypto/test/Test/Cardano/Crypto/Gen.hs @@ -52,7 +52,7 @@ import qualified Hedgehog.Range as Range import Cardano.Binary (Annotated(..), Raw(..), ToCBOR) import Cardano.Crypto (PassPhrase) import Cardano.Crypto.Hashing - (AbstractHash(..), Hash, HashAlgorithm, abstractHash, hash) + (AbstractHash, Hash, HashAlgorithm, abstractHash, hash) import Cardano.Crypto.ProtocolMagic ( AProtocolMagic(..) , ProtocolMagic diff --git a/stack.yaml b/stack.yaml index a9ceb7d7..b17dab36 100644 --- a/stack.yaml +++ b/stack.yaml @@ -24,7 +24,7 @@ extra-deps: commit: 2547ad1e80aeabca2899951601079408becbc92c - git: https://github.com/input-output-hk/cardano-base - commit: f869bee9b08ba1044b1476737c9d65083e1c6c7f + commit: 68dcff6e832efa8711b9757d8ddaba61759da973 subdirs: - binary - binary/test