-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Global blockchain state (emulated).

module Michelson.Runtime.GState
  (
    -- * Auxiliary types
    ContractState (..)
  , AddressState (..)
  , asBalance

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

  , initGState
  , readGState
  , writeGState

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

import Control.Lens (at)
import Data.Aeson (FromJSON(..), ToJSON(..), object, withObject, (.:), (.=))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
import Data.Aeson.TH (deriveJSON)
import qualified Data.ByteString.Lazy as LBS
import Data.List.NonEmpty ((!!))
import qualified Data.Map.Strict as Map
import Data.Typeable ((:~:)(..), eqT)
import Fmt (Buildable(build), (+|), (|+), (||+))
import System.IO.Error (IOError, isDoesNotExistError)

import Michelson.TypeCheck
  (SomeContractAndStorage(..), SomeParamType(..), TcOriginatedContracts,
  typeCheckContractAndStorage)
import qualified Michelson.Typed as T
import Michelson.Typed.Scope
import Michelson.Untyped (Contract, Value)
import Tezos.Address (Address(..), ContractHash, GlobalCounter(..))
import Tezos.Core (ChainId, Mutez, divModMutezInt, dummyChainId)
import Tezos.Crypto
import Util.Aeson
import Util.Lens

-- | 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.
  }

deriving stock instance Show ContractState

instance ToJSON ContractState where
  toJSON :: ContractState -> Value
toJSON ContractState{..} =
    [Pair] -> Value
object
    [ "balance" Text -> Mutez -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Mutez
csBalance
    , "storage" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value st -> Value
forall (t :: T). (SingI t, HasNoOp t) => Value' Instr t -> Value
T.untypeValue Value st
csStorage
    , "contract" Text -> Contract -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Contract cp st -> Contract
forall (param :: T) (store :: T).
(SingI param, SingI store) =>
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 "contractstate" ((Object -> Parser ContractState) -> Value -> Parser ContractState)
-> (Object -> Parser ContractState)
-> Value
-> Parser ContractState
forall a b. (a -> b) -> a -> b
$ \o :: Object
o -> do
      (Mutez
balance :: Mutez) <- Object
o Object -> Text -> Parser Mutez
forall a. FromJSON a => Object -> Text -> Parser a
.: "balance"
      (Value
uStorage :: Value) <- Object
o Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: "storage"
      (Contract
uContract :: Contract) <- Object
o Object -> Text -> Parser Contract
forall a. FromJSON a => Object -> Text -> Parser a
.: "contract"
      case Contract -> Value -> Either TCError SomeContractAndStorage
typeCheckContractAndStorage Contract
uContract Value
uStorage of
        Right (SomeContractAndStorage contract :: Contract cp st
contract storage :: 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 -> ContractState
forall (cp :: T) (st :: T).
(ParameterScope cp, StorageScope st) =>
Mutez -> Contract cp st -> Value st -> ContractState
ContractState Mutez
balance Contract cp st
contract Value st
storage
        Left err :: 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
$ "Unable to parse `ContractState`: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (TCError -> String
forall b a. (Show a, IsString b) => a -> b
show TCError
err)

instance Buildable ContractState where
  build :: ContractState -> Builder
build ContractState{..} =
    "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
|+
    "\n  Storage: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Value st -> Value
forall (t :: T). (SingI t, HasNoOp t) => Value' Instr t -> Value
T.untypeValue Value st
csStorage Value -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+
    "\n  Contract: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Contract cp st -> Contract
forall (param :: T) (store :: T).
(SingI param, SingI store) =>
Contract param store -> Contract
T.convertContract Contract cp st
csContract Contract -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ ""

-- | 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, (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 balance :: Mutez
balance -> "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
|+ ""
      ASContract cs :: 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 b :: Mutez
b -> Mutez
b
    ASContract cs :: ContractState
cs -> ContractState -> Mutez
csBalance ContractState
cs

-- | 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 -> GlobalCounter
gsCounter :: GlobalCounter
  -- ^ Ever increasing operation counter.
  } 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)

makeLensesWith postfixLFields ''GState

deriveJSON morleyAesonOptions ''GState

-- | Number of genesis addresses.
genesisAddressesNum :: Word
genesisAddressesNum :: Word
genesisAddressesNum = 10

-- | Secrets from which genesis addresses are derived from.
genesisSecrets :: NonEmpty SecretKey
genesisSecrets :: NonEmpty SecretKey
genesisSecrets = do
  Word
i <- 1 Word -> [Word] -> NonEmpty Word
forall a. a -> [a] -> NonEmpty a
:| [2 .. Word
genesisAddressesNum]
  let seed :: ByteString
seed = Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Word -> Text
forall b a. (Show a, IsString b) => a -> b
show Word
i :: Text)
  SecretKey -> NonEmpty SecretKey
forall (m :: * -> *) a. Monad m => a -> m a
return (SecretKey -> NonEmpty SecretKey)
-> SecretKey -> NonEmpty SecretKey
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> SecretKey
ByteString -> SecretKey
detSecretKey ByteString
seed

-- | KeyHash of genesis address.
genesisKeyHashes :: NonEmpty KeyHash
genesisKeyHashes :: NonEmpty 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) -> NonEmpty SecretKey -> NonEmpty KeyHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty SecretKey
genesisSecrets

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

-- | One of genesis key hashes.
genesisKeyHash :: KeyHash
genesisKeyHash :: KeyHash
genesisKeyHash = NonEmpty KeyHash -> KeyHash
forall a. NonEmpty a -> a
head NonEmpty KeyHash
genesisKeyHashes

-- | One of genesis addresses.
genesisAddress :: Address
genesisAddress :: Address
genesisAddress = NonEmpty Address -> Address
forall a. NonEmpty a -> a
head NonEmpty Address
genesisAddresses

-- | Secret key assotiated with 'genesisAddress'.
genesisSecretKey :: SecretKey
genesisSecretKey :: SecretKey
genesisSecretKey = NonEmpty SecretKey -> SecretKey
forall a. NonEmpty a -> a
head NonEmpty SecretKey
genesisSecrets

-- | More genesis addresses
--
-- We know size of @genesisAddresses@, so it is safe to use @!!@
genesisAddress1, genesisAddress2, genesisAddress3 :: Address
genesisAddress4, genesisAddress5, genesisAddress6 :: Address
genesisAddress1 :: Address
genesisAddress1 = NonEmpty Address
genesisAddresses NonEmpty Address -> Int -> Address
forall a. NonEmpty a -> Int -> a
!! 1
genesisAddress2 :: Address
genesisAddress2 = NonEmpty Address
genesisAddresses NonEmpty Address -> Int -> Address
forall a. NonEmpty a -> Int -> a
!! 2
genesisAddress3 :: Address
genesisAddress3 = NonEmpty Address
genesisAddresses NonEmpty Address -> Int -> Address
forall a. NonEmpty a -> Int -> a
!! 3
genesisAddress4 :: Address
genesisAddress4 = NonEmpty Address
genesisAddresses NonEmpty Address -> Int -> Address
forall a. NonEmpty a -> Int -> a
!! 4
genesisAddress5 :: Address
genesisAddress5 = NonEmpty Address
genesisAddresses NonEmpty Address -> Int -> Address
forall a. NonEmpty a -> Int -> a
!! 5
genesisAddress6 :: Address
genesisAddress6 = NonEmpty Address
genesisAddresses NonEmpty Address -> Int -> Address
forall a. NonEmpty a -> Int -> a
!! 6

-- | 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 =
  $WGState :: ChainId -> Map Address AddressState -> GlobalCounter -> 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 (money :: Mutez
money, _) = Bounded Mutez => Mutez
forall a. Bounded a => a
maxBound @Mutez Mutez -> Word -> Maybe (Mutez, Mutez)
forall a. Integral a => Mutez -> a -> Maybe (Mutez, Mutez)
`divModMutezInt` Word
genesisAddressesNum
                    Maybe (Mutez, Mutez) -> (Mutez, Mutez) -> (Mutez, Mutez)
forall a. Maybe a -> a -> a
?: Text -> (Mutez, Mutez)
forall a. HasCallStack => Text -> a
error "Number of genesis addresses is 0"
    , Address
genesis <- NonEmpty Address -> [Element (NonEmpty Address)]
forall t. Container t => t -> [Element t]
toList NonEmpty Address
genesisAddresses
    ]
  , gsCounter :: GlobalCounter
gsCounter = Word64 -> GlobalCounter
GlobalCounter 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 str :: String
str) = "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 fp :: 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 lByteString :: 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 exc :: 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 fp :: String
fp gs :: 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

deriving stock instance Show GStateUpdate

instance Buildable GStateUpdate where
  build :: GStateUpdate -> Builder
build =
    \case
      GSAddAddress addr :: Address
addr st :: AddressState
st ->
        "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
|+ " 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
|+ ""
      GSSetStorageValue addr :: Address
addr tVal :: Value st
tVal ->
        "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
|+ " to " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Value st -> Value
forall (t :: T). (SingI 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
|+ ""
      GSSetBalance addr :: Address
addr balance :: Mutez
balance ->
        "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
|+ " 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
|+ ""
      GSIncrementCounter ->
        "Increment internal counter after operation"

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 addr :: Address
addr -> "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 addr :: Address
addr -> "Unknown address: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Address -> Builder
forall p. Buildable p => p -> Builder
build Address
addr
      GStateNotContract addr :: Address
addr -> "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 addr :: Address
addr ->
        "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 addr :: Address
addr st :: 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 addr :: Address
addr newValue :: 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 addr :: Address
addr newBalance :: Mutez
newBalance -> Address -> Mutez -> GState -> Either GStateUpdateError GState
setBalance Address
addr Mutez
newBalance
    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
+1)

-- | 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 addr :: Address
addr st :: AddressState
st gs :: 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 addr :: Address
addr newValue :: 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 _) = GStateUpdateError -> Either GStateUpdateError AddressState
forall a b. a -> Either a b
Left (Address -> GStateUpdateError
GStateNotContract Address
addr)
    modifier (ASContract (ContractState b :: Mutez
b c :: Contract cp st
c (Value st
_ :: T.Value st') )) = do
      case ((Typeable st, Typeable st) => Maybe (st :~: st)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @st @st') of
        Just 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
$ Mutez -> Contract cp st -> Value st -> ContractState
forall (cp :: T) (st :: T).
(ParameterScope cp, StorageScope st) =>
Mutez -> Contract cp st -> Value st -> ContractState
ContractState Mutez
b Contract cp st
c Value st
Value st
newValue
        _ -> 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 storage value associated with given address.
setBalance :: Address -> Mutez -> GState -> Either GStateUpdateError GState
setBalance :: Address -> Mutez -> GState -> Either GStateUpdateError GState
setBalance addr :: Address
addr newBalance :: Mutez
newBalance = Address
-> (AddressState -> Either GStateUpdateError AddressState)
-> GState
-> Either GStateUpdateError GState
updateAddressState Address
addr (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
. AddressState -> AddressState
modifier)
  where
    modifier :: AddressState -> AddressState
modifier (ASSimple _) = Mutez -> AddressState
ASSimple Mutez
newBalance
    modifier (ASContract cs :: ContractState
cs) = ContractState -> AddressState
ASContract (ContractState
cs {csBalance :: Mutez
csBalance = Mutez
newBalance})

updateAddressState ::
     Address
  -> (AddressState -> Either GStateUpdateError AddressState)
  -> GState
  -> Either GStateUpdateError GState
updateAddressState :: Address
-> (AddressState -> Either GStateUpdateError AddressState)
-> GState
-> Either GStateUpdateError GState
updateAddressState addr :: Address
addr f :: AddressState -> Either GStateUpdateError AddressState
f gs :: 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
    Nothing -> GStateUpdateError -> Either GStateUpdateError GState
forall a b. a -> Either a b
Left (Address -> GStateUpdateError
GStateUnknownAddress Address
addr)
    Just as :: 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

-- | Retrive 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 _, ASSimple {}) -> Maybe (ContractHash, SomeParamType)
forall a. Maybe a
Nothing
            (KeyAddress _, _) -> Text -> Maybe (ContractHash, SomeParamType)
forall a. HasCallStack => Text -> a
error "broken GState"
            (ContractAddress ca :: ContractHash
ca, ASContract (ContractState{..})) ->
              (ContractHash, SomeParamType)
-> Maybe (ContractHash, SomeParamType)
forall a. a -> Maybe a
Just (ContractHash
ca, Sing cp -> ParamNotes cp -> SomeParamType
forall (t :: T).
ParameterScope t =>
Sing t -> ParamNotes t -> SomeParamType
SomeParamType Sing cp
forall k (a :: k). SingI a => Sing a
sing (ParamNotes cp -> SomeParamType) -> ParamNotes cp -> SomeParamType
forall a b. (a -> b) -> a -> b
$ Contract cp st -> ParamNotes cp
forall (cp :: T) (st :: T). Contract 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 _, _) -> Text -> Maybe (ContractHash, SomeParamType)
forall a. HasCallStack => Text -> a
error "broken GState"