CAD-1874

When viewing the contents of a compact address (as in the TxOut
pattern), stop deserializing data that is not referenced (via laziness).

shelley/chain-and-ledger/executable-spec/.ghcid

@@ -1 +1 @@
--c "nix-shell ../../../shell.nix --run \"cabal repl -f development shelley-spec-ledger\"" -o ghcid.txt
+-c "nix-shell ../../../shell.nix --run \"cabal repl -f development shelley-spec-ledger\"" -o quickfix

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs

@@ -63,6 +63,7 @@ import Shelley.Spec.Ledger.Rewards
 import Shelley.Spec.Ledger.STS.NewEpoch (calculatePoolDistr)
 import Shelley.Spec.Ledger.STS.Tickn (TicknState (..))
 import Shelley.Spec.Ledger.TxBody (PoolParams (..), TxOut (..))
+import Shelley.Spec.Ledger.DeserializeShort (compactAddr)
 import Shelley.Spec.Ledger.UTxO (UTxO (..))
 
 -- | Get pool sizes, but in terms of total stake
@@ -193,7 +194,7 @@ getFilteredUTxO ss addrs =
     UTxO fullUTxO = getUTxO ss
     -- Instead of decompacting each address in the huge UTxO, compact each
     -- address in the small set of address.
-    addrSBSs = Set.map (BSS.toShort . serialiseAddr) addrs
+    addrSBSs = Set.map compactAddr addrs
 
 -- | Get the (private) leader schedule for this epoch.
 --

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Address.hs

@@ -178,7 +178,7 @@ deserialiseRewardAcnt bs = case B.runGetOrFail getRewardAcnt (BSL.fromStrict bs)
 
 -- | An address for UTxO.
 data Addr era
-  = Addr !Network !(PaymentCredential era) !(StakeReference era)
+  = Addr Network (PaymentCredential era) (StakeReference era)
   | AddrBootstrap !(BootstrapAddress era)
   deriving (Show, Eq, Generic, NFData, Ord)
 

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/DeserializeShort.hs

@@ -1,19 +1,23 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Shelley.Spec.Ledger.DeserializeShort
-  ( deserialiseAddrStakeRef,
-    deserializeShortAddr,
+  ( compactAddr,
+    decompactAddr,
+    CompactAddr,
   )
 where
 
+import Cardano.Prelude (panic, cborError)
 import qualified Cardano.Crypto.Hash.Class as Hash
 import Cardano.Ledger.Crypto (ADDRHASH)
 import Cardano.Ledger.Era (Crypto (..))
 import Control.Monad (ap, join)
 import qualified Control.Monad.Fail
 import Data.Bits (testBit, (.&.))
+import Data.ByteString (ByteString)
 import Data.ByteString.Short as SBS
 import Data.ByteString.Short.Internal (ShortByteString (SBS))
 import qualified Data.Primitive.ByteArray as BA
@@ -29,6 +33,7 @@ import Shelley.Spec.Ledger.Address
     stakeCredIsScript,
     toWord7,
     word7sToNat,
+    serialiseAddr,
   )
 import Shelley.Spec.Ledger.BaseTypes (word8ToNetwork)
 import Shelley.Spec.Ledger.Credential
@@ -40,6 +45,50 @@ import Shelley.Spec.Ledger.Credential
 import Shelley.Spec.Ledger.Keys (KeyHash (..))
 import Shelley.Spec.Ledger.Scripts (ScriptHash (..))
 import Shelley.Spec.Ledger.Slot (SlotNo (..))
+import Cardano.Binary
+   (decodeFull', FromCBOR (..), DecoderError(..), ToCBOR(..))
+import Shelley.Spec.Ledger.Address (Addr (..), BootstrapAddress (..))
+import Data.Maybe (fromMaybe)
+
+newtype CompactAddr era = CompactAddr ShortByteString
+  deriving (Eq, Ord)
+
+compactAddr :: Era era => Addr era -> CompactAddr era
+compactAddr = CompactAddr . SBS.toShort . serialiseAddr
+
+decompactAddr :: forall era. Era era => CompactAddr era -> Addr era
+decompactAddr (CompactAddr bytes) = if testBit header byron
+  then AddrBootstrap $ run 0 bytes getBootstrapAddress
+  else Addr addrNetId paycred stakecred
+  where
+  run :: forall a. Int -> ShortByteString -> GetShort a -> a
+  run i sbs g = snd . unwrap  $ runGetShort g i sbs
+  -- The reason failure is impossible here is that the only way to call this code
+  -- is using a CompactAddr, which can only be constructed using compactAddr.
+  -- compactAddr serializes an Addr, so this is guaranteed to work.
+  unwrap :: forall a. Maybe a -> a
+  unwrap = fromMaybe (panic "Impossible failure when decoding compact address")
+  header = run 0 bytes getWord
+  addrNetId = unwrap $ word8ToNetwork $ header .&. 0x0F -- 0b00001111 is the mask for the network id
+  -- The address format is
+  -- header | pay cred | stake cred
+  -- where the header is 1 byte
+  -- the pay cred is (sizeHash (ADDRHASH (Crypto era))) bytes
+  -- and the stake cred can vary
+  paycred = run 1 bytes (getPayCred header)
+  stakecred = run 1 bytes $ do
+    skipHash ([] @(ADDRHASH (Crypto era)))
+    getStakeReference header
+
+instance Era era => ToCBOR (CompactAddr era) where
+  toCBOR (CompactAddr bytes) = toCBOR bytes
+
+instance Era era => FromCBOR (CompactAddr era) where
+  fromCBOR = do
+    sbs <- fromCBOR
+    case deserializeShortAddr @era sbs of
+      Just _ -> pure $ CompactAddr sbs
+      Nothing -> cborError $ DecoderErrorCustom "Addr" "invalid address"
 
 newtype GetShort a = GetShort {runGetShort :: Int -> ShortByteString -> Maybe (Int, a)}
   deriving (Functor)
@@ -68,26 +117,34 @@ getAddrStakeReference = do
     else skipHash ([] @(ADDRHASH (Crypto era))) >> Just <$> getStakeReference header
 
 deserializeShortAddr :: Era era => ShortByteString -> Maybe (Addr era)
-deserializeShortAddr short =
-  case runGetShort getShortAddr 0 short of
-    Just (_, maybe_addr) -> maybe_addr
-    Nothing -> Nothing
+deserializeShortAddr short = snd <$> runGetShort getShortAddr 0 short
 
-getShortAddr :: forall era. Era era => GetShort (Maybe (Addr era))
+getShortAddr :: forall era. Era era => GetShort (Addr era)
 getShortAddr = do
   header <- peekWord8
   if testBit header byron
-    then pure Nothing
+    then getByronAddress
     else do
       _ <- getWord -- read past the header byte
       let addrNetId = header .&. 0x0F -- 0b00001111 is the mask for the network id
       case word8ToNetwork addrNetId of
-        Just n -> do c <- getPayCred header; h <- getStakeReference header; pure (Just (Addr n c h))
+        Just n -> do
+           c <- getPayCred header
+           h <- getStakeReference header
+           pure (Addr n c h)
         Nothing ->
           fail $
             concat
               ["Address with unknown network Id. (", show addrNetId, ")"]
 
+getBootstrapAddress :: GetShort (BootstrapAddress era)
+getBootstrapAddress = do
+  bs <- getRemainingAsByteString
+  case decodeFull' bs of
+    Left e -> fail $ show e
+    Right r -> pure $ BootstrapAddress r
+
+
 getWord :: GetShort Word8
 getWord = GetShort $ \i sbs ->
   if i < SBS.length sbs
@@ -99,6 +156,13 @@ peekWord8 = GetShort peek
   where
     peek i sbs = if i < SBS.length sbs then Just (i, SBS.index sbs i) else Nothing
 
+getRemainingAsByteString :: GetShort ByteString
+getRemainingAsByteString = GetShort $ \i sbs ->
+  let l = SBS.length sbs
+   in if i < l
+    then Just $ (l, SBS.fromShort $ substring sbs i l)
+    else Nothing
+
 skipHash :: forall proxy h. Hash.HashAlgorithm h => proxy h -> GetShort ()
 skipHash p = skip . fromIntegral $ Hash.sizeHash p
 
@@ -122,6 +186,12 @@ skip n = GetShort $ \i sbs ->
         then Just (offsetStop, ())
         else Nothing
 
+viewOffset :: GetShort Int
+viewOffset = GetShort $ \i sbs -> Just (i,i)
+
+setOffset :: Int -> GetShort ()
+setOffset n = GetShort $ \_i _sbs -> Just (n, ())
+
 getWord7s :: GetShort [Word7]
 getWord7s = do
   next <- getWord

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/EpochBoundary.hs

@@ -51,12 +51,12 @@ import Shelley.Spec.Ledger.Coin
     coinToRational,
     rationalToCoinViaFloor,
   )
+import Shelley.Spec.Ledger.Address (Addr(..))
 import Shelley.Spec.Ledger.Credential (Credential, Ptr, StakeReference (..))
-import Shelley.Spec.Ledger.DeserializeShort (deserialiseAddrStakeRef)
 import Shelley.Spec.Ledger.Keys (KeyHash, KeyRole (..))
 import Shelley.Spec.Ledger.PParams (PParams, PParams' (..), _a0, _nOpt)
 import Shelley.Spec.Ledger.Serialization (decodeRecordNamed)
-import Shelley.Spec.Ledger.TxBody (PoolParams, TxOut (TxOutCompact))
+import Shelley.Spec.Ledger.TxBody (PoolParams, TxOut (TxOut))
 import Shelley.Spec.Ledger.UTxO (UTxO (..))
 
 -- | Blocks made
@@ -98,14 +98,13 @@ aggregateUtxoCoinByCredential ::
 aggregateUtxoCoinByCredential ptrs (UTxO u) initial =
   Map.foldr accum initial u
   where
-    accum (TxOutCompact addr c) ans =
-      let c' = Val.coin . Core.fromCompact @(Core.Value era) $ c
-       in case deserialiseAddrStakeRef addr of
-            Just (StakeRefPtr p) -> case Map.lookup p ptrs of
-              Just cred -> Map.insertWith (<>) cred c' ans
-              Nothing -> ans
-            Just (StakeRefBase hk) -> Map.insertWith (<>) hk c' ans
-            _other -> ans
+    accum (TxOut (Addr _ _ (StakeRefPtr p)) c) ans =
+      case Map.lookup p ptrs of
+        Just cred -> Map.insertWith (<>) cred (Val.coin c) ans
+        Nothing -> ans
+    accum (TxOut (Addr _ _ (StakeRefBase hk)) c) ans =
+      Map.insertWith (<>) hk (Val.coin c) ans
+    accum _other ans = ans
 
 -- | Get stake of one pool
 poolStake ::

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxBody.hs

@@ -151,7 +151,8 @@ import Shelley.Spec.Ledger.Credential
     Ptr (..),
     StakeCredential,
   )
-import Shelley.Spec.Ledger.DeserializeShort (deserializeShortAddr)
+import Shelley.Spec.Ledger.DeserializeShort
+   (compactAddr, decompactAddr, CompactAddr)
 import Shelley.Spec.Ledger.Hashing
 import Shelley.Spec.Ledger.Keys
   ( Hash,
@@ -439,7 +440,7 @@ instance NoThunks (TxIn era)
 -- | The output of a UTxO.
 data TxOut era
   = TxOutCompact
-      {-# UNPACK #-} !BSS.ShortByteString
+      {-# UNPACK #-} !(CompactAddr era)
       !(Core.CompactForm (Core.Value era))
 
 instance
@@ -467,7 +468,7 @@ pattern TxOut addr vl <-
   where
     TxOut addr vl =
       -- TODO check this
-      TxOutCompact (BSS.toShort $ serialiseAddr addr) (Core.toCompact vl)
+      TxOutCompact (compactAddr addr) (Core.toCompact vl)
 
 {-# COMPLETE TxOut #-}
 
@@ -478,19 +479,9 @@ viewCompactTxOut ::
   (Addr era, Core.Value era)
 viewCompactTxOut (TxOutCompact bs c) = (addr, val)
   where
-    addr = case decompactAddr bs of
-      Nothing -> panic "viewCompactTxOut: impossible"
-      Just a -> a
+    addr = decompactAddr bs
     val = Core.fromCompact c
 
-decompactAddr :: Era era => BSS.ShortByteString -> Maybe (Addr era)
-decompactAddr bs =
-  -- Try to deserialize a Shelley style Addr directly from ShortByteString
-  case deserializeShortAddr bs of
-    Just a -> Just a
-    -- It is a Byron Address, try the more expensive route.
-    Nothing -> deserialiseAddr (BSS.fromShort bs)
-
 data DelegCert era
   = -- | A stake key registration certificate.
     RegKey !(StakeCredential era)
@@ -867,14 +858,9 @@ instance
   FromCBOR (TxOut era)
   where
   fromCBOR = decodeRecordNamed "TxOut" (const 2) $ do
-    bs <- fromCBOR
+    compactAddr <- fromCBOR
     coin <- fromCBOR
-    -- Check that the address is valid by decompacting it instead of decoding
-    -- it as an address, as that would require compacting (re-encoding) it
-    -- afterwards.
-    case decompactAddr bs of
-      Just (_ :: Addr era) -> pure $ TxOutCompact bs coin
-      Nothing -> cborError $ DecoderErrorCustom "TxOut" "invalid address"
+    pure $ TxOutCompact compactAddr coin
 
 instance
   (Typeable kr, Era era) =>

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/UTxO.hs

@@ -260,7 +260,7 @@ balance ::
   Core.Value era
 balance (UTxO utxo) = Map.foldl' addTxOuts mempty utxo
   where
-    addTxOuts !b (TxOutCompact _ (Core.fromCompact -> a)) = a <+> b
+    addTxOuts !b (TxOut _ a) = a <+> b
 
 -- | Determine the total deposit amount needed.
 -- The block may (legitimately) contain multiple registration certificates