- INLINE -> INLINEABLE in Core, Address - set flags -flate-specialize and -fspecialize-aggressively in Core, Address - INLINE umElemFoo functions in UMap
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -flate-specialise -fspecialise-aggressively #-}
module Cardano.Ledger.Address (
mkRwdAcnt,
serialiseAddr,
-- | Serialise an address to the external format.
serialiseAddr :: Addr c -> ByteString
serialiseAddr = BSL.toStrict . B.runPut . putAddr
{-# INLINE serialiseAddr #-}
{-# INLINEABLE serialiseAddr #-}
-- | Deserialise an address from the external format. This will fail if the
-- input data is not in the right format (or if there is trailing data).
deserialiseAddr :: Crypto c => ByteString -> Maybe (Addr c)
deserialiseAddr = decodeAddr
{-# INLINE deserialiseAddr #-}
{-# INLINEABLE deserialiseAddr #-}
-- | Serialise a reward account to the external format.
serialiseRewardAcnt :: RewardAcnt c -> ByteString
serialiseRewardAcnt = BSL.toStrict . B.runPut . putRewardAcnt
{-# INLINE serialiseRewardAcnt #-}
{-# INLINEABLE serialiseRewardAcnt #-}
-- | Deserialise a reward account from the external format. This will fail if the
-- input data is not in the right format (or if there is trailing data).
deserialiseRewardAcnt :: Crypto c => ByteString -> Maybe (RewardAcnt c)
deserialiseRewardAcnt = decodeRewardAcnt
{-# INLINE deserialiseRewardAcnt #-}
{-# INLINEABLE deserialiseRewardAcnt #-}
-- | An address for UTxO.
--
let header = setPayCredBit $ netId `setBit` isEnterpriseAddr `setBit` notBaseAddr
B.putWord8 header
putCredential pc
{-# INLINE putAddr #-}
{-# INLINEABLE putAddr #-}
putRewardAcnt :: RewardAcnt c -> Put
putRewardAcnt (RewardAcnt network cred) = do
header = setPayCredBit (netId .|. rewardAcntPrefix)
B.putWord8 header
putCredential cred
{-# INLINE putRewardAcnt #-}
{-# INLINEABLE putRewardAcnt #-}
putHash :: Hash.Hash h a -> Put
putHash = B.putByteString . Hash.hashToBytes
{-# INLINE putHash #-}
{-# INLINEABLE putHash #-}
putCredential :: Credential kr c -> Put
putCredential (ScriptHashObj (ScriptHash h)) = putHash h
putCredential (KeyHashObj (KeyHash h)) = putHash h
{-# INLINE putCredential #-}
{-# INLINEABLE putCredential #-}
-- | The size of the extra attributes in a bootstrp (ie Byron) address. Used
-- to help enforce that people do not post huge ones on the chain.
instance Crypto c => EncCBOR (Addr c) where
encCBOR = encCBOR . B.runPut . putAddr
{-# INLINE encCBOR #-}
{-# INLINEABLE encCBOR #-}
instance Crypto c => DecCBOR (Addr c) where
decCBOR = fromCborAddr
{-# INLINE decCBOR #-}
{-# INLINEABLE decCBOR #-}
instance Crypto c => EncCBOR (RewardAcnt c) where
encCBOR = encCBOR . B.runPut . putRewardAcnt
{-# INLINE encCBOR #-}
{-# INLINEABLE encCBOR #-}
instance Crypto c => DecCBOR (RewardAcnt c) where
decCBOR = fromCborRewardAcnt
{-# INLINE decCBOR #-}
{-# INLINEABLE decCBOR #-}
newtype BootstrapAddress c = BootstrapAddress
{ unBootstrapAddress :: Byron.Address
-- | Unwrap the compact address and get to the address' binary representation.
unCompactAddr :: CompactAddr c -> ShortByteString
unCompactAddr (UnsafeCompactAddr sbs) = sbs
{-# INLINE unCompactAddr #-}
{-# INLINEABLE unCompactAddr #-}
compactAddr :: Addr c -> CompactAddr c
compactAddr = UnsafeCompactAddr . SBS.toShort . serialiseAddr
{-# INLINE compactAddr #-}
{-# INLINEABLE compactAddr #-}
decompactAddr :: forall c. (HasCallStack, Crypto c) => CompactAddr c -> Addr c
decompactAddr (UnsafeCompactAddr sbs) =
"Impossible: Malformed CompactAddr was allowed into the system. "
++ " Decoder error: "
++ err
{-# INLINE decompactAddr #-}
{-# INLINEABLE decompactAddr #-}
------------------------------------------------------------------------------------------
-- Address Serializer --------------------------------------------------------------------
-- | Decoder for an `Addr`. Works in all eras
fromCborAddr :: forall c s. Crypto c => Decoder s (Addr c)
fromCborAddr = fst <$> fromCborBothAddr
{-# INLINE fromCborAddr #-}
{-# INLINEABLE fromCborAddr #-}
-- | Returns the actual bytes that represent an addres, while ensuring that they can
-- be decoded in any era as an `Addr` when need be.
fromCborCompactAddr :: forall c s. Crypto c => Decoder s (CompactAddr c)
fromCborCompactAddr = snd <$> fromCborBothAddr
{-# INLINE fromCborCompactAddr #-}
{-# INLINEABLE fromCborCompactAddr #-}
-- | This is the decoder for an address that returns both the actual `Addr` and the bytes,
-- that it was encoded as.
flip evalStateT 0 $ do
addr <- decodeAddrStateAllowLeftoverT False sbs
pure (addr, UnsafeCompactAddr sbs)
{-# INLINE decodeAddrRigorous #-}
{-# INLINE fromCborBothAddr #-}
{-# INLINEABLE decodeAddrRigorous #-}
{-# INLINEABLE fromCborBothAddr #-}
-- | Prior to Babbage era we did not check if a binary blob representing an address was
-- fully consumed, so unfortunately we must preserve this behavior. However, we do not
bytesConsumed <- get
let sbsCropped = SBS.toShort $ BS.take bytesConsumed $ SBS.fromShort sbs
pure (addr, UnsafeCompactAddr sbsCropped)
{-# INLINE fromCborBackwardsBothAddr #-}
{-# INLINEABLE fromCborBackwardsBothAddr #-}
class AddressBuffer b where
bufLength :: b -> Int
instance AddressBuffer ShortByteString where
bufLength = SBS.length
{-# INLINE bufLength #-}
{-# INLINEABLE bufLength #-}
bufUnsafeIndex = unsafeShortByteStringIndex
{-# INLINE bufUnsafeIndex #-}
{-# INLINEABLE bufUnsafeIndex #-}
bufToByteString = SBS.fromShort
{-# INLINE bufToByteString #-}
{-# INLINEABLE bufToByteString #-}
bufGetHash = Hash.hashFromOffsetBytesShort
{-# INLINE bufGetHash #-}
{-# INLINEABLE bufGetHash #-}
instance AddressBuffer BS.ByteString where
bufLength = BS.length
{-# INLINE bufLength #-}
{-# INLINEABLE bufLength #-}
bufUnsafeIndex = BS.unsafeIndex
{-# INLINE bufUnsafeIndex #-}
{-# INLINEABLE bufUnsafeIndex #-}
bufToByteString = id
{-# INLINE bufToByteString #-}
{-# INLINEABLE bufToByteString #-}
bufGetHash :: forall h a. Hash.HashAlgorithm h => BS.ByteString -> Int -> Maybe (Hash.Hash h a)
bufGetHash bs offset = do
let size = fromIntegral (Hash.sizeHash (Proxy :: Proxy h))
guard (offset >= 0 && offset + size <= BS.length bs)
Hash.hashFromBytes (BS.unsafeTake size (BS.unsafeDrop offset bs))
{-# INLINE bufGetHash #-}
{-# INLINEABLE bufGetHash #-}
-- | Address header byte truth table:
newtype Header = Header Word8
isByronAddress :: Header -> Bool
isByronAddress = (== headerByron)
{-# INLINE isByronAddress #-}
{-# INLINEABLE isByronAddress #-}
headerNonShelleyBits :: Header
headerNonShelleyBits = headerByron .|. 0b00001100
headerNetworkId header
| header `testBit` 0 = Mainnet
| otherwise = Testnet
{-# INLINE headerNetworkId #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -Wno-orphans -Wno-redundant-constraints -flate-specialise -fspecialise-aggressively #-}
-- | This module defines core type families which we know to vary from era to
-- era.
Right cValue -> fromCompact cValue
)
(\txOut value -> txOut & valueEitherTxOutL .~ Left value)
{-# INLINE valueTxOutL #-}
{-# INLINEABLE valueTxOutL #-}
compactValueTxOutL :: HasCallStack => Lens' (TxOut era) (CompactForm (Value era))
compactValueTxOutL =
Right cValue -> cValue
)
(\txOut cValue -> txOut & valueEitherTxOutL .~ Right cValue)
{-# INLINE compactValueTxOutL #-}
{-# INLINEABLE compactValueTxOutL #-}
-- | Lens for getting and setting in TxOut either an address or its compact
-- version by doing the least amount of work.
Right cAddr -> decompactAddr cAddr
)
(\txOut addr -> txOut & addrEitherTxOutL .~ Left addr)
{-# INLINE addrTxOutL #-}
{-# INLINEABLE addrTxOutL #-}
compactAddrTxOutL :: Lens' (TxOut era) (CompactAddr (EraCrypto era))
compactAddrTxOutL =
Right cAddr -> cAddr
)
(\txOut cAddr -> txOut & addrEitherTxOutL .~ Right cAddr)
{-# INLINE compactAddrTxOutL #-}
{-# INLINEABLE compactAddrTxOutL #-}
-- | Lens for getting and setting in TxOut either an address or its compact
-- version by doing the least amount of work.
AddrBootstrap bootstrapAddr <- Just (decompactAddr cAddr)
Just bootstrapAddr
_ -> Nothing
{-# INLINE bootAddrTxOutF #-}
{-# INLINEABLE bootAddrTxOutF #-}
coinTxOutL :: (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL =
Right cVal ->
txOut & compactValueTxOutL .~ modifyCompactCoin (const (toCompactPartial c)) cVal
)
{-# INLINE coinTxOutL #-}
{-# INLINEABLE coinTxOutL #-}
compactCoinTxOutL :: (HasCallStack, EraTxOut era) => Lens' (TxOut era) (CompactForm Coin)
compactCoinTxOutL =
Right cVal ->
txOut & compactValueTxOutL .~ modifyCompactCoin (const cCoin) cVal
)
{-# INLINE compactCoinTxOutL #-}
{-# INLINEABLE compactCoinTxOutL #-}
-- | This is a getter that implements an efficient way to check whether 'TxOut'
-- contains ADA only.
TFFEF r p v -> (SJust r, p, SNothing, SJust v)
TFFFE r p s -> (SJust r, p, SJust s, SNothing)
TFFFF r p s v -> (SJust r, p, SJust s, SJust v)
{-# INLINE umElemAsTuple #-}
-- | Extract a delegated reward-deposit pair if it is present.
-- We can tell that the pair is present and active when Txxxx has
TFFFE rdA _ _ -> Just rdA
TFFFF rdA _ _ _ -> Just rdA
_ -> Nothing
{-# INLINE umElemRDActive #-}
-- | Extract the reward-deposit pair if it is present.
-- We can tell that the reward is present when Txxxx has an F in the first position
TFFFE r _ _ -> Just r
TFFFF r _ _ _ -> Just r
_ -> Nothing
{-# INLINE umElemRDPair #-}
-- | Extract the set of pointers if it is non-empty.
-- We can tell that the reward is present when Txxxx has an F in the second position
TFFFE _ p _ | not (Set.null p) -> Just p
TFFFF _ p _ _ | not (Set.null p) -> Just p
_ -> Nothing
{-# INLINE umElemPtrs #-}
-- | Extract the stake delegatee pool id, if present.
-- We can tell that the pool id is present when Txxxx has an F in the third position
TFFFE _ _ s -> Just s
TFFFF _ _ s _ -> Just s
_ -> Nothing
{-# INLINE umElemSPool #-}
-- | Extract the voting delegatee id, if present.
-- We can tell that the delegatee is present when Txxxx has an F in the fourth position
TFFEF _ _ d -> Just d
TFFFF _ _ _ d -> Just d
_ -> Nothing
{-# INLINE umElemDRep #-}
-- | A `UMElem` can be extracted and injected into the `TEEEE` ... `TFFFF` constructors.
pattern UMElem ::
* Removed call to tail, and the 'watchPulser' test Co-authored-by: Alexey Kuleshevich <[email protected]>
Reimplementation of #496 targetting #819, which include the more general changes of #500.
Introduces `IOSimThreadIdMap` data type as an optimization over the previous time and memory innefficient Map data structure.
To prevent aborting the wrong Head `headId` was added to the `OnAbortTx`. Logic layer now aborts the head that is seen as initialized.
Co-authored-by: Torsten Schmits <[email protected]>
refactor: remove indirect KeyAgent dependency on ObservableWallet
