Make network id value level

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

@@ -17,6 +17,7 @@ module Shelley.Spec.Ledger.Address
     serialiseAddr,
     deserialiseAddr,
     Addr (..),
+    getNetwork,
     -- internals exported for testing
     getAddr,
     getKeyHash,
@@ -37,7 +38,6 @@ import Cardano.Binary (DecoderError (..), FromCBOR (..), ToCBOR (..), decodeFull
 import qualified Cardano.Chain.Common as Byron
 import qualified Cardano.Crypto.Hash.Class as Hash
 import Cardano.Prelude (NFData, NoUnexpectedThunks, cborError)
-import Control.Monad (unless)
 import Data.Binary (Get, Put, Word8)
 import qualified Data.Binary as B
 import qualified Data.Binary.Get as B
@@ -50,6 +50,7 @@ import Data.String (fromString)
 import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import Numeric.Natural (Natural)
+import Shelley.Spec.Ledger.BaseTypes (Network (..), networkToWord8, word8ToNetwork)
 import Shelley.Spec.Ledger.Credential
   ( Credential (..),
     PaymentCredential,
@@ -76,9 +77,10 @@ mkRwdAcnt key@(KeyHashObj _) = RewardAcnt key
 
 toAddr ::
   Crypto crypto =>
+  Network ->
   (KeyPair 'Payment crypto, KeyPair 'Staking crypto) ->
   Addr crypto
-toAddr (payKey, stakeKey) = Addr (toCred payKey) (StakeRefBase $ toCred stakeKey)
+toAddr n (payKey, stakeKey) = Addr n (toCred payKey) (StakeRefBase $ toCred stakeKey)
 
 toCred ::
   Crypto crypto =>
@@ -94,12 +96,12 @@ scriptToCred :: Crypto crypto => MultiSig crypto -> Credential kr crypto
 scriptToCred = ScriptHashObj . hashMultiSigScript
 
 -- | Create a base address from a pair of multi-sig scripts (pay and stake)
-scriptsToAddr :: Crypto crypto => (MultiSig crypto, MultiSig crypto) -> Addr crypto
-scriptsToAddr (payScript, stakeScript) =
-  Addr (scriptToCred payScript) (StakeRefBase $ scriptToCred stakeScript)
+scriptsToAddr :: Crypto crypto => Network -> (MultiSig crypto, MultiSig crypto) -> Addr crypto
+scriptsToAddr n (payScript, stakeScript) =
+  Addr n (scriptToCred payScript) (StakeRefBase $ scriptToCred stakeScript)
 
 -- | Serialise an address to the external format.
-serialiseAddr :: Crypto crypto => Addr crypto -> ByteString
+serialiseAddr :: Addr crypto -> ByteString
 serialiseAddr = BSL.toStrict . B.runPut . putAddr
 
 -- | Deserialise an address from the external format. This will fail if the
@@ -111,10 +113,17 @@ deserialiseAddr bs = case B.runGetOrFail getAddr (BSL.fromStrict bs) of
 
 -- | An address for UTxO.
 data Addr crypto
-  = Addr !(PaymentCredential crypto) !(StakeReference crypto)
+  = Addr !Network !(PaymentCredential crypto) !(StakeReference crypto)
   | AddrBootstrap !(Byron.Address)
   deriving (Show, Eq, Generic, NFData, Ord)
 
+getNetwork :: Addr crypto -> Network
+getNetwork (Addr n _ _) = n
+getNetwork (AddrBootstrap byronAddr) =
+  case Byron.aaNetworkMagic . Byron.attrData . Byron.addrAttributes $ byronAddr of
+    Byron.NetworkMainOrStage -> Mainnet
+    Byron.NetworkTestnet _ -> Testnet
+
 instance NoUnexpectedThunks (Addr crypto)
 
 byron :: Int
@@ -132,13 +141,13 @@ stakeCredIsScript = 5
 payCredIsScript :: Int
 payCredIsScript = 4
 
-putAddr :: forall crypto. Crypto crypto => Addr crypto -> Put
+putAddr :: Addr crypto -> Put
 putAddr (AddrBootstrap byronAddr) = B.putLazyByteString (serialize byronAddr)
-putAddr (Addr pc sr) =
+putAddr (Addr network pc sr) =
   let setPayCredBit = case pc of
         ScriptHashObj _ -> flip setBit payCredIsScript
         KeyHashObj _ -> id
-      netId = networkToWord8 $ networkMagicId ([] @crypto)
+      netId = networkToWord8 network
    in case sr of
         StakeRefBase sc -> do
           let setStakeCredBit = case sc of
@@ -166,17 +175,12 @@ getAddr = do
     else do
       _ <- B.getWord8 -- read past the header byte
       let addrNetId = header .&. 0x0F -- 0b00001111 is the mask for the network id
-          netId = networkToWord8 $ networkMagicId ([] @crypto)
-      unless (addrNetId == netId) $ fail $
-        concat
-          [ "Got address with incorrect network Id. \n",
-            "Expected: ",
-            show netId,
-            "\n",
-            "Got: ",
-            show addrNetId
-          ]
-      Addr <$> getPayCred header <*> getStakeReference header
+      case word8ToNetwork addrNetId of
+        Just n -> Addr n <$> getPayCred header <*> getStakeReference header
+        Nothing ->
+          fail $
+            concat
+              ["Address with unknown network Id. (", show addrNetId, ")"]
 
 getHash :: forall h a. Hash.HashAlgorithm h => Get (Hash.Hash h a)
 getHash = Hash.UnsafeHash <$> B.getByteString (fromIntegral $ Hash.sizeHash ([] @h))

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

@@ -1,4 +1,6 @@
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -11,6 +13,9 @@ module Shelley.Spec.Ledger.BaseTypes
   ( FixedPoint,
     (==>),
     (⭒),
+    Network (..),
+    networkToWord8,
+    word8ToNetwork,
     Nonce (..),
     Seed (..),
     UnitInterval (..),
@@ -57,7 +62,7 @@ import Cardano.Binary
     matchSize,
   )
 import Cardano.Crypto.Hash
-import Cardano.Prelude (NoUnexpectedThunks (..), cborError)
+import Cardano.Prelude (NFData, NoUnexpectedThunks (..), cborError)
 import Cardano.Slotting.EpochInfo
 import Control.Monad.Trans.Reader (ReaderT)
 import qualified Data.ByteString as BS
@@ -91,7 +96,8 @@ fpEpsilon = (10 :: FixedPoint) ^ (17 :: Integer) / fpPrecision
 
 -- | Type to represent a value in the unit interval [0; 1]
 newtype UnitInterval = UnsafeUnitInterval Rational -- TODO: Fixed precision
-  deriving (Show, Ord, Eq, NoUnexpectedThunks, Generic)
+  deriving (Show, Ord, Eq, Generic)
+  deriving newtype (NoUnexpectedThunks)
 
 instance ToCBOR UnitInterval where
   toCBOR (UnsafeUnitInterval u) = rationalToCBOR u
@@ -166,7 +172,8 @@ mkNonce = Nonce . coerce . hash @SHA256
 --   We do not expose the constructor to `Seed`. Instead, a `Seed` should be
 --   created using `mkSeed` for a VRF calculation.
 newtype Seed = Seed (Hash SHA256 Seed)
-  deriving (Eq, Ord, Show, Generic, NoUnexpectedThunks, ToCBOR)
+  deriving (Eq, Ord, Show, Generic)
+  deriving newtype (NoUnexpectedThunks, ToCBOR)
 
 (==>) :: Bool -> Bool -> Bool
 a ==> b = not a || b
@@ -251,7 +258,8 @@ text64FromCBOR = do
 --
 
 newtype Url = Url {urlToText :: Text}
-  deriving (Eq, Ord, Generic, Show, ToCBOR, NoUnexpectedThunks)
+  deriving (Eq, Ord, Generic, Show)
+  deriving newtype (ToCBOR, NoUnexpectedThunks)
 
 textToUrl :: Text -> Maybe Url
 textToUrl t = Url <$> text64 t
@@ -260,7 +268,8 @@ instance FromCBOR Url where
   fromCBOR = Url <$> text64FromCBOR
 
 newtype DnsName = DnsName {dnsToText :: Text}
-  deriving (Eq, Ord, Generic, Show, ToCBOR, NoUnexpectedThunks)
+  deriving (Eq, Ord, Generic, Show)
+  deriving newtype (ToCBOR, NoUnexpectedThunks)
 
 textToDns :: Text -> Maybe DnsName
 textToDns t = DnsName <$> text64 t
@@ -269,7 +278,8 @@ instance FromCBOR DnsName where
   fromCBOR = DnsName <$> text64FromCBOR
 
 newtype Port = Port {portToWord16 :: Word16}
-  deriving (Eq, Ord, Num, Generic, Show, ToCBOR, FromCBOR, NoUnexpectedThunks)
+  deriving (Eq, Ord, Generic, Show)
+  deriving newtype (Num, FromCBOR, ToCBOR, NoUnexpectedThunks)
 
 --------------------------------------------------------------------------------
 -- Active Slot Coefficent, named f in
@@ -353,10 +363,34 @@ data Globals = Globals
     maxLovelaceSupply :: !Word64,
     -- | Active Slot Coefficient, named f in
     -- "Ouroboros Praos: An adaptively-secure, semi-synchronous proof-of-stake protocol"
-    activeSlotCoeff :: !ActiveSlotCoeff
+    activeSlotCoeff :: !ActiveSlotCoeff,
+    -- | The network ID
+    networkId :: !Network
   }
   deriving (Generic)
 
 instance NoUnexpectedThunks Globals
 
 type ShelleyBase = ReaderT Globals Identity
+
+data Network
+  = Testnet
+  | Mainnet
+  deriving (Eq, Ord, Enum, Bounded, Show, Generic, NFData, NoUnexpectedThunks)
+
+networkToWord8 :: Network -> Word8
+networkToWord8 = toEnum . fromEnum
+
+word8ToNetwork :: Word8 -> Maybe Network
+word8ToNetwork e
+  | fromEnum e > fromEnum (maxBound :: Network) = Nothing
+  | fromEnum e < fromEnum (minBound :: Network) = Nothing
+  | otherwise = Just $ toEnum (fromEnum e)
+
+instance ToCBOR Network where
+  toCBOR = toCBOR . networkToWord8
+
+instance FromCBOR Network where
+  fromCBOR = word8ToNetwork <$> fromCBOR >>= \case
+    Nothing -> cborError $ DecoderErrorCustom "Network" "Unknown network id"
+    Just n -> pure n

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

@@ -10,7 +10,6 @@ import Cardano.Crypto.KES
 import Cardano.Crypto.VRF
 import Data.Kind (Type)
 import Data.Typeable (Typeable)
-import Data.Word (Word8)
 
 class
   ( HashAlgorithm (HASH c),
@@ -28,12 +27,3 @@ class
   type DSIGN c :: Type
   type KES c :: Type
   type VRF c :: Type
-  networkMagicId :: proxy c -> Network
-
-data Network
-  = Testnet
-  | Mainnet
-  deriving (Eq, Ord, Enum)
-
-networkToWord8 :: Network -> Word8
-networkToWord8 = toEnum . fromEnum

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

@@ -76,7 +76,7 @@ newtype Stake crypto = Stake {unStake :: (Map (Credential 'Staking crypto) Coin)
 
 -- | Extract hash of staking key from base address.
 getStakeHK :: Addr crypto -> Maybe (Credential 'Staking crypto)
-getStakeHK (Addr _ (StakeRefBase hk)) = Just hk
+getStakeHK (Addr _ _ (StakeRefBase hk)) = Just hk
 getStakeHK _ = Nothing
 
 aggregateOuts :: UTxO crypto -> Map (Addr crypto) Coin
@@ -98,7 +98,7 @@ baseStake vals =
 
 -- | Extract pointer from pointer address.
 getStakePtr :: Addr crypto -> Maybe Ptr
-getStakePtr (Addr _ (StakeRefPtr ptr)) = Just ptr
+getStakePtr (Addr _ _ (StakeRefPtr ptr)) = Just ptr
 getStakePtr _ = Nothing
 
 -- | Calculate stake of pointer addresses in TxOut set.

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

@@ -766,7 +766,7 @@ witsVKeyNeeded utxo' tx@(Tx txbody _ _ _) _genDelegs =
     unspendableKeyHash = KeyHash (coerce (hash 0 :: Hash crypto Int))
     insertHK txin hkeys =
       case txinLookup txin utxo' of
-        Just (TxOut (Addr (KeyHashObj pay) _) _) -> Set.insert pay hkeys
+        Just (TxOut (Addr _ (KeyHashObj pay) _) _) -> Set.insert pay hkeys
         Just (TxOut (AddrBootstrap _) _) -> Set.insert unspendableKeyHash hkeys
         -- NOTE: Until Byron addresses are supported, we insert an unspendible keyhash
         _ -> hkeys