-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | Global blockchain state (emulated).

module Morley.Michelson.Runtime.GState
  (
    -- * Auxiliary types
    ContractState (..)
  , AddressState (..)
  , asBalance
  , VotingPowers (..)
  , vpPick
  , vpTotal
  , mkVotingPowers
  , mkVotingPowersFromMap
  , dummyVotingPowers
  , BigMapCounter(..)
  , bigMapCounter

  -- * GState
  , GState (..)
  , gsChainIdL
  , gsAddressesL
  , gsVotingPowersL
  , gsCounterL
  , gsBigMapCounterL
  , genesisAddresses
  , genesisKeyHashes
  , genesisAddress
  -- * More genesisAddresses which can be used in tests
  , genesisAddress1
  , genesisAddress2
  , genesisAddress3
  , genesisAddress4
  , genesisAddress5
  , genesisAddress6
  , genesisAddressN
  , genesisKeyHash
  -- * Genesis secret keys
  , genesisSecretKey
  , genesisSecrets

  , initGState
  , readGState
  , writeGState

  -- * Operations on GState
  , GStateUpdate (..)
  , GStateUpdateError (..)
  , applyUpdate
  , applyUpdates
  , extractAllContracts
  ) where

import Control.Lens (at, makeLenses)
import Data.Aeson (FromJSON(..), ToJSON(..), object, withObject, (.:), (.:?), (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty qualified as Aeson
import Data.Aeson.TH (deriveJSON)
import Data.ByteString.Lazy qualified as LBS
import Data.Default (def)
import Data.Map.Strict qualified as Map
import Data.Type.Equality ((:~:)(..))
import Fmt (Buildable(build), pretty, (+|), (|+))
import System.IO.Error (IOError, isDoesNotExistError)

import Morley.Michelson.TypeCheck
  (SomeParamType(..), TcOriginatedContracts, typeCheckContractAndStorage, typeCheckingWith)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.Existential (SomeContractAndStorage(..))
import Morley.Michelson.Typed.Scope
import Morley.Michelson.Untyped (Contract, Value)
import Morley.Tezos.Address (Address(..), ContractHash, GlobalCounter(..))
import Morley.Tezos.Core (ChainId, Mutez, divModMutezInt, dummyChainId)
import Morley.Tezos.Crypto
import Morley.Util.Aeson
import Morley.Util.Lens
import Morley.Util.Peano
import Morley.Util.Sing (eqI, eqParamSing, eqParamSing2)
import Morley.Util.SizedList qualified as SL
import Morley.Util.SizedList.Types

-- | State of a contract with code.
data ContractState =
  forall cp st. (ParameterScope cp, StorageScope st) => ContractState
  { ContractState -> Mutez
csBalance :: Mutez
  -- ^ Amount of mutez owned by this contract.
  , ()
csContract :: T.Contract cp st
  -- ^ Contract itself.
  , ()
csStorage :: T.Value st
  -- ^ Storage value associated with this contract.
  , ContractState -> Maybe KeyHash
csDelegate :: Maybe KeyHash
  -- ^ Delegate associated with this contract.
  }

deriving stock instance Show ContractState

instance Eq ContractState where
  ContractState Mutez
b1 Contract cp st
c1 Value st
s1 Maybe KeyHash
d1 == :: ContractState -> ContractState -> Bool
== ContractState Mutez
b2 Contract cp st
c2 Value st
s2 Maybe KeyHash
d2 =
    Mutez
b1 Mutez -> Mutez -> Bool
forall a. Eq a => a -> a -> Bool
== Mutez
b2
    Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
&& Contract cp st -> Contract cp st -> Bool
forall k1 k2 (a1 :: k1) (a2 :: k1) (b1 :: k2) (b2 :: k2)
       (t :: k1 -> k2 -> *).
(SingI a1, SingI a2, SingI b1, SingI b2, SDecide k1, SDecide k2,
 Eq (t a1 b2)) =>
t a1 b1 -> t a2 b2 -> Bool
eqParamSing2 Contract cp st
c1 Contract cp st
c2
    Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
&& Value st -> Value st -> Bool
forall k (a1 :: k) (a2 :: k) (t :: k -> *).
(SingI a1, SingI a2, SDecide k, Eq (t a1)) =>
t a1 -> t a2 -> Bool
eqParamSing Value st
s1 Value st
s2
    Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
&& Maybe KeyHash
d1 Maybe KeyHash -> Maybe KeyHash -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe KeyHash
d2

instance ToJSON ContractState where
  toJSON :: ContractState -> Value
toJSON ContractState{Maybe KeyHash
Mutez
Contract cp st
Value st
csDelegate :: Maybe KeyHash
csStorage :: Value st
csContract :: Contract cp st
csBalance :: Mutez
csDelegate :: ContractState -> Maybe KeyHash
csStorage :: ()
csContract :: ()
csBalance :: ContractState -> Mutez
..} =
    [Pair] -> Value
object ([Pair] -> Value) -> ([Pair] -> [Pair]) -> [Pair] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    ([Pair] -> [Pair])
-> (KeyHash -> [Pair] -> [Pair])
-> Maybe KeyHash
-> [Pair]
-> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Pair] -> [Pair]
forall a. a -> a
id ((:) (Pair -> [Pair] -> [Pair])
-> (KeyHash -> Pair) -> KeyHash -> [Pair] -> [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"delegate" Text -> KeyHash -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=)) Maybe KeyHash
csDelegate ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
    [ Text
"balance" Text -> Mutez -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Mutez
csBalance
    , Text
"storage" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value st -> Value
forall (t :: T). HasNoOp t => Value' Instr t -> Value
T.untypeValue Value st
csStorage
    , Text
"contract" Text -> Contract -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Contract cp st -> Contract
forall (param :: T) (store :: T). Contract param store -> Contract
T.convertContract Contract cp st
csContract
    ]

-- These instance is a bit hacky because it is quite painful to
-- write proper JSON instances for typed `Instr` and `Value` so
-- we typecheck untyped representation instead of parsing.
instance FromJSON ContractState where
  parseJSON :: Value -> Parser ContractState
parseJSON =
    String
-> (Object -> Parser ContractState)
-> Value
-> Parser ContractState
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"contractstate" ((Object -> Parser ContractState) -> Value -> Parser ContractState)
-> (Object -> Parser ContractState)
-> Value
-> Parser ContractState
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
      (Mutez
balance :: Mutez) <- Object
o Object -> Text -> Parser Mutez
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"balance"
      (Value
uStorage :: Value) <- Object
o Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"storage"
      (Contract
uContract :: Contract) <- Object
o Object -> Text -> Parser Contract
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"contract"
      (Maybe KeyHash
delegate :: Maybe KeyHash) <- Object
o Object -> Text -> Parser (Maybe KeyHash)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"delegate"
      case TypeCheckOptions
-> TypeCheckResult SomeContractAndStorage
-> Either TCError SomeContractAndStorage
forall a. TypeCheckOptions -> TypeCheckResult a -> Either TCError a
typeCheckingWith TypeCheckOptions
forall a. Default a => a
def (TypeCheckResult SomeContractAndStorage
 -> Either TCError SomeContractAndStorage)
-> TypeCheckResult SomeContractAndStorage
-> Either TCError SomeContractAndStorage
forall a b. (a -> b) -> a -> b
$ Contract -> Value -> TypeCheckResult SomeContractAndStorage
typeCheckContractAndStorage Contract
uContract Value
uStorage of
        Right (SomeContractAndStorage Contract cp st
contract Value st
storage) ->
          ContractState -> Parser ContractState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ContractState -> Parser ContractState)
-> ContractState -> Parser ContractState
forall a b. (a -> b) -> a -> b
$ Mutez
-> Contract cp st -> Value st -> Maybe KeyHash -> ContractState
forall (cp :: T) (st :: T).
(ParameterScope cp, StorageScope st) =>
Mutez
-> Contract cp st -> Value st -> Maybe KeyHash -> ContractState
ContractState Mutez
balance Contract cp st
contract Value st
storage Maybe KeyHash
delegate
        Left TCError
err -> String -> Parser ContractState
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ContractState) -> String -> Parser ContractState
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse `ContractState`: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TCError -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty TCError
err

instance Buildable ContractState where
  build :: ContractState -> Builder
build ContractState{Maybe KeyHash
Mutez
Contract cp st
Value st
csDelegate :: Maybe KeyHash
csStorage :: Value st
csContract :: Contract cp st
csBalance :: Mutez
csDelegate :: ContractState -> Maybe KeyHash
csStorage :: ()
csContract :: ()
csBalance :: ContractState -> Mutez
..} =
    Builder
"Contractstate:\n Balance: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Mutez
csBalance Mutez -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+
    Builder
"\n  Storage: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Value st -> Value
forall (t :: T). HasNoOp t => Value' Instr t -> Value
T.untypeValue Value st
csStorage Value -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+
    Builder
"\n  Contract: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Contract cp st -> Contract
forall (param :: T) (store :: T). Contract param store -> Contract
T.convertContract Contract cp st
csContract Contract -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+
    Builder
"\n  Delegate: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Maybe KeyHash
csDelegate Maybe KeyHash -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""

-- | State of an arbitrary address.
data AddressState
  = ASSimple Mutez
  -- ^ For contracts without code we store only its balance.
  | ASContract ContractState
  -- ^ For contracts with code we store more state represented by
  -- 'ContractState'.
  deriving stock (Int -> AddressState -> ShowS
[AddressState] -> ShowS
AddressState -> String
(Int -> AddressState -> ShowS)
-> (AddressState -> String)
-> ([AddressState] -> ShowS)
-> Show AddressState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AddressState] -> ShowS
$cshowList :: [AddressState] -> ShowS
show :: AddressState -> String
$cshow :: AddressState -> String
showsPrec :: Int -> AddressState -> ShowS
$cshowsPrec :: Int -> AddressState -> ShowS
Show, AddressState -> AddressState -> Bool
(AddressState -> AddressState -> Bool)
-> (AddressState -> AddressState -> Bool) -> Eq AddressState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AddressState -> AddressState -> Bool
$c/= :: AddressState -> AddressState -> Bool
== :: AddressState -> AddressState -> Bool
$c== :: AddressState -> AddressState -> Bool
Eq, (forall x. AddressState -> Rep AddressState x)
-> (forall x. Rep AddressState x -> AddressState)
-> Generic AddressState
forall x. Rep AddressState x -> AddressState
forall x. AddressState -> Rep AddressState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AddressState x -> AddressState
$cfrom :: forall x. AddressState -> Rep AddressState x
Generic)

instance Buildable AddressState where
  build :: AddressState -> Builder
build =
    \case
      ASSimple Mutez
balance -> Builder
"Balance = " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Mutez
balance Mutez -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
      ASContract ContractState
cs -> ContractState -> Builder
forall p. Buildable p => p -> Builder
build ContractState
cs

deriveJSON morleyAesonOptions ''AddressState

-- | Extract balance from 'AddressState'.
asBalance :: AddressState -> Mutez
asBalance :: AddressState -> Mutez
asBalance =
  \case
    ASSimple Mutez
b -> Mutez
b
    ASContract ContractState
cs -> ContractState -> Mutez
csBalance ContractState
cs

-- | Distribution of voting power among the contracts.
--
-- Voting power reflects the ability of bakers to accept, deny or pass new
-- proposals for protocol updates. I.e. each baker has its vote weight.
--
-- This datatype definition may change in future, so its internals are not
-- exported.
newtype VotingPowers
  = VotingPowers (Map KeyHash Natural)
  deriving stock (Int -> VotingPowers -> ShowS
[VotingPowers] -> ShowS
VotingPowers -> String
(Int -> VotingPowers -> ShowS)
-> (VotingPowers -> String)
-> ([VotingPowers] -> ShowS)
-> Show VotingPowers
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VotingPowers] -> ShowS
$cshowList :: [VotingPowers] -> ShowS
show :: VotingPowers -> String
$cshow :: VotingPowers -> String
showsPrec :: Int -> VotingPowers -> ShowS
$cshowsPrec :: Int -> VotingPowers -> ShowS
Show, VotingPowers -> VotingPowers -> Bool
(VotingPowers -> VotingPowers -> Bool)
-> (VotingPowers -> VotingPowers -> Bool) -> Eq VotingPowers
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VotingPowers -> VotingPowers -> Bool
$c/= :: VotingPowers -> VotingPowers -> Bool
== :: VotingPowers -> VotingPowers -> Bool
$c== :: VotingPowers -> VotingPowers -> Bool
Eq)

deriveJSON morleyAesonOptions ''VotingPowers

-- | Get voting power of the given address.
vpPick :: KeyHash -> VotingPowers -> Natural
vpPick :: KeyHash -> VotingPowers -> Natural
vpPick KeyHash
key (VotingPowers Map KeyHash Natural
distr) = KeyHash -> Map KeyHash Natural -> Maybe Natural
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash
key Map KeyHash Natural
distr Maybe Natural -> Natural -> Natural
forall a. Maybe a -> a -> a
?: Natural
0

-- | Get total voting power.
vpTotal :: VotingPowers -> Natural
vpTotal :: VotingPowers -> Natural
vpTotal (VotingPowers Map KeyHash Natural
distr) = Map KeyHash Natural -> Element (Map KeyHash Natural)
forall t. (Container t, Num (Element t)) => t -> Element t
sum Map KeyHash Natural
distr

-- | Create voting power distribution from map.
mkVotingPowersFromMap :: Map KeyHash Natural -> VotingPowers
mkVotingPowersFromMap :: Map KeyHash Natural -> VotingPowers
mkVotingPowersFromMap = Map KeyHash Natural -> VotingPowers
VotingPowers

-- | Create voting power distribution.
--
-- If some key is encountered multiple times, voting power will be summed up.
mkVotingPowers :: [(KeyHash, Natural)] -> VotingPowers
mkVotingPowers :: [(KeyHash, Natural)] -> VotingPowers
mkVotingPowers = Map KeyHash Natural -> VotingPowers
mkVotingPowersFromMap (Map KeyHash Natural -> VotingPowers)
-> ([(KeyHash, Natural)] -> Map KeyHash Natural)
-> [(KeyHash, Natural)]
-> VotingPowers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural -> Natural -> Natural)
-> [(KeyHash, Natural)] -> Map KeyHash Natural
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(+)

-- | All big_maps stored in a chain have a globally unique ID.
--
-- We use this counter to keep track of how many big_maps have been created so far,
-- and to generate new IDs whenever a new big_map is created.
newtype BigMapCounter = BigMapCounter { BigMapCounter -> Natural
_bigMapCounter :: Natural }
  deriving stock (Int -> BigMapCounter -> ShowS
[BigMapCounter] -> ShowS
BigMapCounter -> String
(Int -> BigMapCounter -> ShowS)
-> (BigMapCounter -> String)
-> ([BigMapCounter] -> ShowS)
-> Show BigMapCounter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BigMapCounter] -> ShowS
$cshowList :: [BigMapCounter] -> ShowS
show :: BigMapCounter -> String
$cshow :: BigMapCounter -> String
showsPrec :: Int -> BigMapCounter -> ShowS
$cshowsPrec :: Int -> BigMapCounter -> ShowS
Show, BigMapCounter -> BigMapCounter -> Bool
(BigMapCounter -> BigMapCounter -> Bool)
-> (BigMapCounter -> BigMapCounter -> Bool) -> Eq BigMapCounter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BigMapCounter -> BigMapCounter -> Bool
$c/= :: BigMapCounter -> BigMapCounter -> Bool
== :: BigMapCounter -> BigMapCounter -> Bool
$c== :: BigMapCounter -> BigMapCounter -> Bool
Eq, (forall x. BigMapCounter -> Rep BigMapCounter x)
-> (forall x. Rep BigMapCounter x -> BigMapCounter)
-> Generic BigMapCounter
forall x. Rep BigMapCounter x -> BigMapCounter
forall x. BigMapCounter -> Rep BigMapCounter x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BigMapCounter x -> BigMapCounter
$cfrom :: forall x. BigMapCounter -> Rep BigMapCounter x
Generic)
  deriving anyclass (BigMapCounter -> ()
(BigMapCounter -> ()) -> NFData BigMapCounter
forall a. (a -> ()) -> NFData a
rnf :: BigMapCounter -> ()
$crnf :: BigMapCounter -> ()
NFData)
  deriving newtype ([BigMapCounter] -> Encoding
[BigMapCounter] -> Value
BigMapCounter -> Encoding
BigMapCounter -> Value
(BigMapCounter -> Value)
-> (BigMapCounter -> Encoding)
-> ([BigMapCounter] -> Value)
-> ([BigMapCounter] -> Encoding)
-> ToJSON BigMapCounter
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [BigMapCounter] -> Encoding
$ctoEncodingList :: [BigMapCounter] -> Encoding
toJSONList :: [BigMapCounter] -> Value
$ctoJSONList :: [BigMapCounter] -> Value
toEncoding :: BigMapCounter -> Encoding
$ctoEncoding :: BigMapCounter -> Encoding
toJSON :: BigMapCounter -> Value
$ctoJSON :: BigMapCounter -> Value
ToJSON, Value -> Parser [BigMapCounter]
Value -> Parser BigMapCounter
(Value -> Parser BigMapCounter)
-> (Value -> Parser [BigMapCounter]) -> FromJSON BigMapCounter
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [BigMapCounter]
$cparseJSONList :: Value -> Parser [BigMapCounter]
parseJSON :: Value -> Parser BigMapCounter
$cparseJSON :: Value -> Parser BigMapCounter
FromJSON, Integer -> BigMapCounter
BigMapCounter -> BigMapCounter
BigMapCounter -> BigMapCounter -> BigMapCounter
(BigMapCounter -> BigMapCounter -> BigMapCounter)
-> (BigMapCounter -> BigMapCounter -> BigMapCounter)
-> (BigMapCounter -> BigMapCounter -> BigMapCounter)
-> (BigMapCounter -> BigMapCounter)
-> (BigMapCounter -> BigMapCounter)
-> (BigMapCounter -> BigMapCounter)
-> (Integer -> BigMapCounter)
-> Num BigMapCounter
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> BigMapCounter
$cfromInteger :: Integer -> BigMapCounter
signum :: BigMapCounter -> BigMapCounter
$csignum :: BigMapCounter -> BigMapCounter
abs :: BigMapCounter -> BigMapCounter
$cabs :: BigMapCounter -> BigMapCounter
negate :: BigMapCounter -> BigMapCounter
$cnegate :: BigMapCounter -> BigMapCounter
* :: BigMapCounter -> BigMapCounter -> BigMapCounter
$c* :: BigMapCounter -> BigMapCounter -> BigMapCounter
- :: BigMapCounter -> BigMapCounter -> BigMapCounter
$c- :: BigMapCounter -> BigMapCounter -> BigMapCounter
+ :: BigMapCounter -> BigMapCounter -> BigMapCounter
$c+ :: BigMapCounter -> BigMapCounter -> BigMapCounter
Num, BigMapCounter -> Builder
(BigMapCounter -> Builder) -> Buildable BigMapCounter
forall p. (p -> Builder) -> Buildable p
build :: BigMapCounter -> Builder
$cbuild :: BigMapCounter -> Builder
Buildable)

makeLenses ''BigMapCounter

-- | Persistent data passed to Morley contracts which can be updated
-- as result of contract execution.
data GState = GState
  { GState -> ChainId
gsChainId :: ChainId
  -- ^ Identifier of chain.
  , GState -> Map Address AddressState
gsAddresses :: Map Address AddressState
  -- ^ All known addresses and their state.
  , GState -> VotingPowers
gsVotingPowers :: VotingPowers
  -- ^ Voting power distribution.
  , GState -> GlobalCounter
gsCounter :: GlobalCounter
  -- ^ Ever increasing operation counter.
  , GState -> BigMapCounter
gsBigMapCounter :: BigMapCounter
  } deriving stock (Int -> GState -> ShowS
[GState] -> ShowS
GState -> String
(Int -> GState -> ShowS)
-> (GState -> String) -> ([GState] -> ShowS) -> Show GState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GState] -> ShowS
$cshowList :: [GState] -> ShowS
show :: GState -> String
$cshow :: GState -> String
showsPrec :: Int -> GState -> ShowS
$cshowsPrec :: Int -> GState -> ShowS
Show, GState -> GState -> Bool
(GState -> GState -> Bool)
-> (GState -> GState -> Bool) -> Eq GState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GState -> GState -> Bool
$c/= :: GState -> GState -> Bool
== :: GState -> GState -> Bool
$c== :: GState -> GState -> Bool
Eq)

makeLensesWith postfixLFields ''GState

deriveJSON morleyAesonOptions ''GState

-- | Number of genesis addresses, type-level
type GenesisAddressesNum = 10

-- | Convenience synonym
type GenesisList a = SizedList GenesisAddressesNum a

-- | Number of genesis addresses, term-level
genesisAddressesNum :: Natural
genesisAddressesNum :: Natural
genesisAddressesNum = Proxy GenesisAddressesNum -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal @GenesisAddressesNum Proxy GenesisAddressesNum
forall k (t :: k). Proxy t
Proxy

-- | Secrets from which genesis addresses are derived from.
genesisSecrets :: GenesisList SecretKey
genesisSecrets :: GenesisList SecretKey
genesisSecrets = forall (n :: Nat) (n' :: Peano) a.
(SingIPeano n, IsoNatPeano n n') =>
(Natural -> a) -> SizedList n a
forall (n' :: Peano) a.
(SingIPeano GenesisAddressesNum,
 IsoNatPeano GenesisAddressesNum n') =>
(Natural -> a) -> SizedList GenesisAddressesNum a
SL.generate @GenesisAddressesNum ((Natural -> SecretKey) -> GenesisList SecretKey)
-> (Natural -> SecretKey) -> GenesisList SecretKey
forall a b. (a -> b) -> a -> b
$ \Natural
i ->
    let seed :: ByteString
seed = Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Natural -> Text
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show (Natural
i Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1) :: Text)
    in HasCallStack => ByteString -> SecretKey
ByteString -> SecretKey
detSecretKey ByteString
seed

-- | KeyHash of genesis address.
genesisKeyHashes :: GenesisList KeyHash
genesisKeyHashes :: GenesisList KeyHash
genesisKeyHashes = PublicKey -> KeyHash
hashKey (PublicKey -> KeyHash)
-> (SecretKey -> PublicKey) -> SecretKey -> KeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecretKey -> PublicKey
toPublic (SecretKey -> KeyHash)
-> SizedList'
     ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) SecretKey
-> SizedList'
     ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) KeyHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) SecretKey
GenesisList SecretKey
genesisSecrets

-- | Initially these addresses have a lot of money.
genesisAddresses :: GenesisList Address
genesisAddresses :: GenesisList Address
genesisAddresses = KeyHash -> Address
KeyAddress (KeyHash -> Address)
-> SizedList'
     ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) KeyHash
-> SizedList'
     ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) Address
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) KeyHash
GenesisList KeyHash
genesisKeyHashes

-- | One of genesis key hashes.
genesisKeyHash :: KeyHash
genesisKeyHash :: KeyHash
genesisKeyHash = SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) KeyHash
-> KeyHash
forall (n :: Peano) a. SizedList' ('S n) a -> a
SL.head SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) KeyHash
GenesisList KeyHash
genesisKeyHashes

-- | One of genesis addresses.
genesisAddress :: Address
genesisAddress :: Address
genesisAddress = SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) Address
-> Address
forall (n :: Peano) a. SizedList' ('S n) a -> a
SL.head SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) Address
GenesisList Address
genesisAddresses

-- | Secret key assotiated with 'genesisAddress'.
genesisSecretKey :: SecretKey
genesisSecretKey :: SecretKey
genesisSecretKey = SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) SecretKey
-> SecretKey
forall (n :: Peano) a. SizedList' ('S n) a -> a
SL.head SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) SecretKey
GenesisList SecretKey
genesisSecrets

-- | More genesis addresses
genesisAddress1, genesisAddress2, genesisAddress3 :: Address
genesisAddress4, genesisAddress5, genesisAddress6 :: Address
Address
_ :< Address
genesisAddress1 :< Address
genesisAddress2 :< Address
genesisAddress3
  :< Address
genesisAddress4 :< Address
genesisAddress5 :< Address
genesisAddress6
  :< SizedList' n Address
_ = SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) Address
GenesisList Address
genesisAddresses

{-# DEPRECATED genesisAddress4, genesisAddress5, genesisAddress6
               "Consider using 'genesisAddressN' instead" #-}

-- | More genesis addresses, via a type-level natural
--
-- > genesisAddressN @7
--
-- Note that @'genesisAddress' == genesisAddressN \@0@, @'genesisAddress1' == genesisAddressN \@1@,
-- etc.
genesisAddressN :: forall n. (SingIPeano n, ToPeano GenesisAddressesNum > ToPeano n ~ 'True) => Address
genesisAddressN :: Address
genesisAddressN = SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) Address
-> Address
forall (i :: Nat) (m :: Peano) a.
((m > ToPeano i) ~ 'True, SingIPeano i) =>
SizedList' m a -> a
SL.index @n SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) Address
GenesisList Address
genesisAddresses

-- | Dummy 'VotingPowers'. We give all the voting power to two genesis addreses
-- as the addresses holding lot of money. Only two addresses are involved for
-- simplicity.
dummyVotingPowers :: VotingPowers
dummyVotingPowers :: VotingPowers
dummyVotingPowers = case GenesisList KeyHash
genesisKeyHashes of
  KeyHash
k1 :< KeyHash
k2 :< SizedList' n KeyHash
_ -> [(KeyHash, Natural)] -> VotingPowers
mkVotingPowers [(KeyHash
k1, Natural
50), (KeyHash
k2, Natural
50)]

-- | Initial 'GState'. It's supposed to be used if no 'GState' is
-- provided. It puts plenty of money on each genesis address.
initGState :: GState
initGState :: GState
initGState =
  GState :: ChainId
-> Map Address AddressState
-> VotingPowers
-> GlobalCounter
-> BigMapCounter
-> GState
GState
  { gsChainId :: ChainId
gsChainId = ChainId
dummyChainId
  , gsAddresses :: Map Address AddressState
gsAddresses = [(Address, AddressState)] -> Map Address AddressState
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Address
genesis, Mutez -> AddressState
ASSimple Mutez
money)
    | let (Mutez
money, Mutez
_) = Bounded Mutez => Mutez
forall a. Bounded a => a
maxBound @Mutez Mutez -> Natural -> Maybe (Mutez, Mutez)
forall a. Integral a => Mutez -> a -> Maybe (Mutez, Mutez)
`divModMutezInt` Natural
genesisAddressesNum
                    Maybe (Mutez, Mutez) -> (Mutez, Mutez) -> (Mutez, Mutez)
forall a. Maybe a -> a -> a
?: Text -> (Mutez, Mutez)
forall a. HasCallStack => Text -> a
error Text
"Number of genesis addresses is 0"
    , Address
genesis <- SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) Address
-> [Element
      (SizedList'
         ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) Address)]
forall t. Container t => t -> [Element t]
toList SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) Address
GenesisList Address
genesisAddresses
    ]
  , gsVotingPowers :: VotingPowers
gsVotingPowers = VotingPowers
dummyVotingPowers
  , gsCounter :: GlobalCounter
gsCounter = Word64 -> GlobalCounter
GlobalCounter Word64
0
  , gsBigMapCounter :: BigMapCounter
gsBigMapCounter = Natural -> BigMapCounter
BigMapCounter Natural
0
  }

data GStateParseError =
  GStateParseError String
  deriving stock (Int -> GStateParseError -> ShowS
[GStateParseError] -> ShowS
GStateParseError -> String
(Int -> GStateParseError -> ShowS)
-> (GStateParseError -> String)
-> ([GStateParseError] -> ShowS)
-> Show GStateParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GStateParseError] -> ShowS
$cshowList :: [GStateParseError] -> ShowS
show :: GStateParseError -> String
$cshow :: GStateParseError -> String
showsPrec :: Int -> GStateParseError -> ShowS
$cshowsPrec :: Int -> GStateParseError -> ShowS
Show)

instance Exception GStateParseError where
  displayException :: GStateParseError -> String
displayException (GStateParseError String
str) = String
"Failed to parse GState: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
str

-- | Read 'GState' from a file.
readGState :: FilePath -> IO GState
readGState :: String -> IO GState
readGState String
fp = (String -> IO ByteString
LBS.readFile String
fp IO ByteString -> (ByteString -> IO GState) -> IO GState
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO GState
parseFile) IO GState -> (IOError -> IO GState) -> IO GState
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` IOError -> IO GState
onExc
  where
    parseFile :: LByteString -> IO GState
    parseFile :: ByteString -> IO GState
parseFile ByteString
lByteString =
      if ByteString -> Bool
forall t. Container t => t -> Bool
null ByteString
lByteString
      then GState -> IO GState
forall (f :: * -> *) a. Applicative f => a -> f a
pure GState
initGState
      else ((String -> IO GState)
-> (GState -> IO GState) -> Either String GState -> IO GState
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (GStateParseError -> IO GState
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (GStateParseError -> IO GState)
-> (String -> GStateParseError) -> String -> IO GState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GStateParseError
GStateParseError) GState -> IO GState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String GState -> IO GState)
-> (ByteString -> Either String GState) -> ByteString -> IO GState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String GState
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode') ByteString
lByteString
    onExc :: IOError -> IO GState
    onExc :: IOError -> IO GState
onExc IOError
exc
      | IOError -> Bool
isDoesNotExistError IOError
exc = GState -> IO GState
forall (f :: * -> *) a. Applicative f => a -> f a
pure GState
initGState
      | Bool
otherwise = IOError -> IO GState
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM IOError
exc

-- | Write 'GState' to a file.
writeGState :: FilePath -> GState -> IO ()
writeGState :: String -> GState -> IO ()
writeGState String
fp GState
gs = String -> ByteString -> IO ()
LBS.writeFile String
fp (Config -> GState -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
Aeson.encodePretty' Config
config GState
gs)
  where
    config :: Config
config =
      Config
Aeson.defConfig
      { confTrailingNewline :: Bool
Aeson.confTrailingNewline = Bool
True
      }

-- | Updates that can be applied to 'GState'.
data GStateUpdate where
  GSAddAddress :: Address -> AddressState -> GStateUpdate
  GSSetStorageValue :: StorageScope st => Address -> T.Value st -> GStateUpdate
  GSSetBalance :: Address -> Mutez -> GStateUpdate
  GSIncrementCounter :: GStateUpdate
  GSUpdateCounter :: GlobalCounter -> GStateUpdate
  GSSetBigMapCounter :: BigMapCounter -> GStateUpdate
  GSSetDelegate :: Address -> Maybe KeyHash -> GStateUpdate

deriving stock instance Show GStateUpdate

instance Buildable GStateUpdate where
  build :: GStateUpdate -> Builder
build =
    \case
      GSAddAddress Address
addr AddressState
st ->
        Builder
"Add address " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Address
addr Address -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" with state " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| AddressState
st AddressState -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
      GSSetStorageValue Address
addr Value st
tVal ->
        Builder
"Set storage value of address " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Address
addr Address -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" to " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Value st -> Value
forall (t :: T). HasNoOp t => Value' Instr t -> Value
T.untypeValue Value st
tVal Value -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
      GSSetBalance Address
addr Mutez
balance ->
        Builder
"Set balance of address " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Address
addr Address -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" to " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Mutez
balance Mutez -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
      GStateUpdate
GSIncrementCounter ->
        Builder
"Increment internal counter after operation"
      GSUpdateCounter GlobalCounter
v ->
        Builder
"Set internal counter to " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| GlobalCounter
v GlobalCounter -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" after interpreting " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"several 'CREATE_CONTRACT' instructions"
      GSSetBigMapCounter BigMapCounter
inc ->
        Builder
"Increment internal big_map counter by: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| BigMapCounter -> Builder
forall p. Buildable p => p -> Builder
build BigMapCounter
inc
      GSSetDelegate Address
addr Maybe KeyHash
key ->
        Builder
"Set delegate for contract " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Address
addr Address -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" to " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Builder -> (KeyHash -> Builder) -> Maybe KeyHash -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
"<nobody>" KeyHash -> Builder
forall p. Buildable p => p -> Builder
build Maybe KeyHash
key

data GStateUpdateError
  = GStateAddressExists Address
  | GStateUnknownAddress Address
  | GStateNotContract Address
  | GStateStorageNotMatch Address
  deriving stock (Int -> GStateUpdateError -> ShowS
[GStateUpdateError] -> ShowS
GStateUpdateError -> String
(Int -> GStateUpdateError -> ShowS)
-> (GStateUpdateError -> String)
-> ([GStateUpdateError] -> ShowS)
-> Show GStateUpdateError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GStateUpdateError] -> ShowS
$cshowList :: [GStateUpdateError] -> ShowS
show :: GStateUpdateError -> String
$cshow :: GStateUpdateError -> String
showsPrec :: Int -> GStateUpdateError -> ShowS
$cshowsPrec :: Int -> GStateUpdateError -> ShowS
Show)

instance Buildable GStateUpdateError where
  build :: GStateUpdateError -> Builder
build =
    \case
      GStateAddressExists Address
addr -> Builder
"Address already exists: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Address -> Builder
forall p. Buildable p => p -> Builder
build Address
addr
      GStateUnknownAddress Address
addr -> Builder
"Unknown address: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Address -> Builder
forall p. Buildable p => p -> Builder
build Address
addr
      GStateNotContract Address
addr -> Builder
"Address doesn't have contract: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Address -> Builder
forall p. Buildable p => p -> Builder
build Address
addr
      GStateStorageNotMatch Address
addr ->
        Builder
"Storage type does not match the contract in run-time state\
        \ when updating new storage value to address: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Address -> Builder
forall p. Buildable p => p -> Builder
build Address
addr

-- | Apply 'GStateUpdate' to 'GState'.
applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState
applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState
applyUpdate =
  \case
    GSAddAddress Address
addr AddressState
st ->
      GStateUpdateError
-> Maybe GState -> Either GStateUpdateError GState
forall l r. l -> Maybe r -> Either l r
maybeToRight (Address -> GStateUpdateError
GStateAddressExists Address
addr) (Maybe GState -> Either GStateUpdateError GState)
-> (GState -> Maybe GState)
-> GState
-> Either GStateUpdateError GState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> AddressState -> GState -> Maybe GState
addAddress Address
addr AddressState
st
    GSSetStorageValue Address
addr Value st
newValue ->
      Address -> Value st -> GState -> Either GStateUpdateError GState
forall (st :: T).
StorageScope st =>
Address -> Value st -> GState -> Either GStateUpdateError GState
setStorageValue Address
addr Value st
newValue
    GSSetBalance Address
addr Mutez
newBalance -> Address -> Mutez -> GState -> Either GStateUpdateError GState
setBalance Address
addr Mutez
newBalance
    GStateUpdate
GSIncrementCounter -> GState -> Either GStateUpdateError GState
forall a b. b -> Either a b
Right (GState -> Either GStateUpdateError GState)
-> (GState -> GState) -> GState -> Either GStateUpdateError GState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter GState GState GlobalCounter GlobalCounter
-> (GlobalCounter -> GlobalCounter) -> GState -> GState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter GState GState GlobalCounter GlobalCounter
Lens' GState GlobalCounter
gsCounterL (GlobalCounter -> GlobalCounter -> GlobalCounter
forall a. Num a => a -> a -> a
+GlobalCounter
1)
    GSUpdateCounter GlobalCounter
newCounter -> GState -> Either GStateUpdateError GState
forall a b. b -> Either a b
Right (GState -> Either GStateUpdateError GState)
-> (GState -> GState) -> GState -> Either GStateUpdateError GState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter GState GState GlobalCounter GlobalCounter
-> GlobalCounter -> GState -> GState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter GState GState GlobalCounter GlobalCounter
Lens' GState GlobalCounter
gsCounterL GlobalCounter
newCounter
    GSSetBigMapCounter BigMapCounter
bmCounter -> GState -> Either GStateUpdateError GState
forall a b. b -> Either a b
Right (GState -> Either GStateUpdateError GState)
-> (GState -> GState) -> GState -> Either GStateUpdateError GState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter GState GState BigMapCounter BigMapCounter
-> BigMapCounter -> GState -> GState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter GState GState BigMapCounter BigMapCounter
Lens' GState BigMapCounter
gsBigMapCounterL BigMapCounter
bmCounter
    GSSetDelegate Address
addr Maybe KeyHash
key -> Address
-> Maybe KeyHash -> GState -> Either GStateUpdateError GState
setDelegate Address
addr Maybe KeyHash
key

-- | Apply a list of 'GStateUpdate's to 'GState'.
applyUpdates :: [GStateUpdate] -> GState -> Either GStateUpdateError GState
applyUpdates :: [GStateUpdate] -> GState -> Either GStateUpdateError GState
applyUpdates = (GState -> [GStateUpdate] -> Either GStateUpdateError GState)
-> [GStateUpdate] -> GState -> Either GStateUpdateError GState
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((GState -> GStateUpdate -> Either GStateUpdateError GState)
-> GState -> [GStateUpdate] -> Either GStateUpdateError GState
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((GStateUpdate -> GState -> Either GStateUpdateError GState)
-> GState -> GStateUpdate -> Either GStateUpdateError GState
forall a b c. (a -> b -> c) -> b -> a -> c
flip GStateUpdate -> GState -> Either GStateUpdateError GState
applyUpdate))

-- | Add an address if it hasn't been added before.
addAddress :: Address -> AddressState -> GState -> Maybe GState
addAddress :: Address -> AddressState -> GState -> Maybe GState
addAddress Address
addr AddressState
st GState
gs
    | Address
addr Address -> Map Address AddressState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Address AddressState
accounts = Maybe GState
forall a. Maybe a
Nothing
    | Bool
otherwise = GState -> Maybe GState
forall a. a -> Maybe a
Just (GState
gs {gsAddresses :: Map Address AddressState
gsAddresses = Map Address AddressState
accounts Map Address AddressState
-> (Map Address AddressState -> Map Address AddressState)
-> Map Address AddressState
forall a b. a -> (a -> b) -> b
& Index (Map Address AddressState)
-> Lens'
     (Map Address AddressState)
     (Maybe (IxValue (Map Address AddressState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Address AddressState)
Address
addr ((Maybe AddressState -> Identity (Maybe AddressState))
 -> Map Address AddressState -> Identity (Map Address AddressState))
-> Maybe AddressState
-> Map Address AddressState
-> Map Address AddressState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AddressState -> Maybe AddressState
forall a. a -> Maybe a
Just AddressState
st})
  where
    accounts :: Map Address AddressState
accounts = GState -> Map Address AddressState
gsAddresses GState
gs

-- | Update storage value associated with given address.
setStorageValue :: forall st. (StorageScope st) =>
     Address -> T.Value st -> GState -> Either GStateUpdateError GState
setStorageValue :: Address -> Value st -> GState -> Either GStateUpdateError GState
setStorageValue Address
addr Value st
newValue = Address
-> (AddressState -> Either GStateUpdateError AddressState)
-> GState
-> Either GStateUpdateError GState
updateAddressState Address
addr AddressState -> Either GStateUpdateError AddressState
modifier
  where
    modifier :: AddressState -> Either GStateUpdateError AddressState
    modifier :: AddressState -> Either GStateUpdateError AddressState
modifier (ASSimple Mutez
_) = GStateUpdateError -> Either GStateUpdateError AddressState
forall a b. a -> Either a b
Left (Address -> GStateUpdateError
GStateNotContract Address
addr)
    modifier (ASContract ContractState{csStorage :: ()
csStorage = Value st
_ :: T.Value st', Maybe KeyHash
Mutez
Contract cp st
csDelegate :: Maybe KeyHash
csContract :: Contract cp st
csBalance :: Mutez
csDelegate :: ContractState -> Maybe KeyHash
csContract :: ()
csBalance :: ContractState -> Mutez
..}) = do
      case (SingI st, SingI st, TestEquality Sing) => Maybe (st :~: st)
forall k (a :: k) (b :: k).
(SingI a, SingI b, TestEquality Sing) =>
Maybe (a :~: b)
eqI @st @st' of
        Just st :~: st
Refl -> AddressState -> Either GStateUpdateError AddressState
forall a b. b -> Either a b
Right (AddressState -> Either GStateUpdateError AddressState)
-> AddressState -> Either GStateUpdateError AddressState
forall a b. (a -> b) -> a -> b
$ ContractState -> AddressState
ASContract (ContractState -> AddressState) -> ContractState -> AddressState
forall a b. (a -> b) -> a -> b
$ ContractState :: forall (cp :: T) (st :: T).
(ParameterScope cp, StorageScope st) =>
Mutez
-> Contract cp st -> Value st -> Maybe KeyHash -> ContractState
ContractState{csStorage :: Value st
csStorage = Value st
newValue, Maybe KeyHash
Mutez
Contract' Instr cp st
Contract cp st
csDelegate :: Maybe KeyHash
csContract :: Contract cp st
csBalance :: Mutez
csDelegate :: Maybe KeyHash
csContract :: Contract' Instr cp st
csBalance :: Mutez
..}
        Maybe (st :~: st)
_ -> GStateUpdateError -> Either GStateUpdateError AddressState
forall a b. a -> Either a b
Left (GStateUpdateError -> Either GStateUpdateError AddressState)
-> GStateUpdateError -> Either GStateUpdateError AddressState
forall a b. (a -> b) -> a -> b
$ Address -> GStateUpdateError
GStateStorageNotMatch Address
addr

-- | Update balance value associated with given address.
setBalance :: Address -> Mutez -> GState -> Either GStateUpdateError GState
setBalance :: Address -> Mutez -> GState -> Either GStateUpdateError GState
setBalance Address
addr Mutez
newBalance = Address
-> (AddressState -> Either GStateUpdateError AddressState)
-> GState
-> Either GStateUpdateError GState
updateAddressState Address
addr ((AddressState -> Either GStateUpdateError AddressState)
 -> GState -> Either GStateUpdateError GState)
-> (AddressState -> Either GStateUpdateError AddressState)
-> GState
-> Either GStateUpdateError GState
forall a b. (a -> b) -> a -> b
$ AddressState -> Either GStateUpdateError AddressState
forall a b. b -> Either a b
Right (AddressState -> Either GStateUpdateError AddressState)
-> (AddressState -> AddressState)
-> AddressState
-> Either GStateUpdateError AddressState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  ASSimple Mutez
_ -> Mutez -> AddressState
ASSimple Mutez
newBalance
  ASContract ContractState
cs -> ContractState -> AddressState
ASContract (ContractState
cs {csBalance :: Mutez
csBalance = Mutez
newBalance})

-- | Set delegate for a given address
setDelegate :: Address -> Maybe KeyHash -> GState -> Either GStateUpdateError GState
setDelegate :: Address
-> Maybe KeyHash -> GState -> Either GStateUpdateError GState
setDelegate Address
addr Maybe KeyHash
key = Address
-> (AddressState -> Either GStateUpdateError AddressState)
-> GState
-> Either GStateUpdateError GState
updateAddressState Address
addr \case
  ASSimple Mutez
_ -> GStateUpdateError -> Either GStateUpdateError AddressState
forall a b. a -> Either a b
Left (GStateUpdateError -> Either GStateUpdateError AddressState)
-> GStateUpdateError -> Either GStateUpdateError AddressState
forall a b. (a -> b) -> a -> b
$ Address -> GStateUpdateError
GStateNotContract Address
addr
  ASContract ContractState
cs -> AddressState -> Either GStateUpdateError AddressState
forall a b. b -> Either a b
Right (AddressState -> Either GStateUpdateError AddressState)
-> AddressState -> Either GStateUpdateError AddressState
forall a b. (a -> b) -> a -> b
$ ContractState -> AddressState
ASContract ContractState
cs{csDelegate :: Maybe KeyHash
csDelegate = Maybe KeyHash
key}

updateAddressState ::
     Address
  -> (AddressState -> Either GStateUpdateError AddressState)
  -> GState
  -> Either GStateUpdateError GState
updateAddressState :: Address
-> (AddressState -> Either GStateUpdateError AddressState)
-> GState
-> Either GStateUpdateError GState
updateAddressState Address
addr AddressState -> Either GStateUpdateError AddressState
f GState
gs =
  case Map Address AddressState
addresses Map Address AddressState
-> Getting
     (Maybe AddressState)
     (Map Address AddressState)
     (Maybe AddressState)
-> Maybe AddressState
forall s a. s -> Getting a s a -> a
^. Index (Map Address AddressState)
-> Lens'
     (Map Address AddressState)
     (Maybe (IxValue (Map Address AddressState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Address AddressState)
Address
addr of
    Maybe AddressState
Nothing -> GStateUpdateError -> Either GStateUpdateError GState
forall a b. a -> Either a b
Left (Address -> GStateUpdateError
GStateUnknownAddress Address
addr)
    Just AddressState
as -> do
      AddressState
newState <- AddressState -> Either GStateUpdateError AddressState
f AddressState
as
      return $ GState
gs { gsAddresses :: Map Address AddressState
gsAddresses = Map Address AddressState
addresses Map Address AddressState
-> (Map Address AddressState -> Map Address AddressState)
-> Map Address AddressState
forall a b. a -> (a -> b) -> b
& Index (Map Address AddressState)
-> Lens'
     (Map Address AddressState)
     (Maybe (IxValue (Map Address AddressState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Address AddressState)
Address
addr ((Maybe AddressState -> Identity (Maybe AddressState))
 -> Map Address AddressState -> Identity (Map Address AddressState))
-> Maybe AddressState
-> Map Address AddressState
-> Map Address AddressState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AddressState -> Maybe AddressState
forall a. a -> Maybe a
Just AddressState
newState }
  where
    addresses :: Map Address AddressState
addresses = GState -> Map Address AddressState
gsAddresses GState
gs

-- | Retrieve all contracts stored in GState
extractAllContracts :: GState -> TcOriginatedContracts
extractAllContracts :: GState -> TcOriginatedContracts
extractAllContracts = [(ContractHash, SomeParamType)] -> TcOriginatedContracts
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ContractHash, SomeParamType)] -> TcOriginatedContracts)
-> (GState -> [(ContractHash, SomeParamType)])
-> GState
-> TcOriginatedContracts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Address, AddressState) -> Maybe (ContractHash, SomeParamType))
-> [(Address, AddressState)] -> [(ContractHash, SomeParamType)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Address, AddressState) -> Maybe (ContractHash, SomeParamType)
extractContract ([(Address, AddressState)] -> [(ContractHash, SomeParamType)])
-> (GState -> [(Address, AddressState)])
-> GState
-> [(ContractHash, SomeParamType)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Address AddressState -> [(Address, AddressState)]
forall t. ToPairs t => t -> [(Key t, Val t)]
toPairs (Map Address AddressState -> [(Address, AddressState)])
-> (GState -> Map Address AddressState)
-> GState
-> [(Address, AddressState)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GState -> Map Address AddressState
gsAddresses
 where
    extractContract
      :: (Address, AddressState) -> Maybe (ContractHash, SomeParamType)
    extractContract :: (Address, AddressState) -> Maybe (ContractHash, SomeParamType)
extractContract =
      \case (KeyAddress KeyHash
_, ASSimple {}) -> Maybe (ContractHash, SomeParamType)
forall a. Maybe a
Nothing
            (KeyAddress KeyHash
_, AddressState
_) -> Text -> Maybe (ContractHash, SomeParamType)
forall a. HasCallStack => Text -> a
error Text
"broken GState"
            (ContractAddress ContractHash
ca, ASContract (ContractState{Maybe KeyHash
Mutez
Contract cp st
Value st
csDelegate :: Maybe KeyHash
csStorage :: Value st
csContract :: Contract cp st
csBalance :: Mutez
csDelegate :: ContractState -> Maybe KeyHash
csStorage :: ()
csContract :: ()
csBalance :: ContractState -> Mutez
..})) ->
              (ContractHash, SomeParamType)
-> Maybe (ContractHash, SomeParamType)
forall a. a -> Maybe a
Just (ContractHash
ca, ParamNotes cp -> SomeParamType
forall (t :: T). ParameterScope t => ParamNotes t -> SomeParamType
SomeParamType (ParamNotes cp -> SomeParamType) -> ParamNotes cp -> SomeParamType
forall a b. (a -> b) -> a -> b
$ Contract cp st -> ParamNotes cp
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
Contract' instr cp st -> ParamNotes cp
T.cParamNotes (Contract cp st -> ParamNotes cp)
-> Contract cp st -> ParamNotes cp
forall a b. (a -> b) -> a -> b
$ Contract cp st
csContract)
            (ContractAddress ContractHash
_, AddressState
_) -> Text -> Maybe (ContractHash, SomeParamType)
forall a. HasCallStack => Text -> a
error Text
"broken GState"