-- | Global blockchain state (emulated).

module Michelson.Runtime.GState
  (
    -- * Auxiliary types
    ContractState (..)
  , getTypedContract
  , getTypedStorage
  , SomeContractAndStorage (..)
  , getTypedContractAndStorage
  , AddressState (..)
  , asBalance

  -- * GState
  , GState (..)
  , gsChainIdL
  , gsAddressesL
  , genesisAddresses
  , genesisKeyHashes
  , genesisAddress
  -- * More genesisAddresses which can be used in tests
  , genesisAddress1
  , genesisAddress2
  , genesisAddress3
  , genesisAddress4
  , genesisAddress5
  , genesisAddress6
  , genesisKeyHash
  , 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 ((+|), (|+), (||+))
import Formatting.Buildable (Buildable(build))
import System.IO.Error (IOError, isDoesNotExistError)

import Michelson.TypeCheck
  (SomeContract(..), TCError, TcOriginatedContracts, typeCheckContract, typeCheckTopLevelType)
import Michelson.Typed (SomeValue, SomeValue'(..))
import qualified Michelson.Typed as T
import Michelson.Typed.Scope
import Michelson.Untyped (Contract, ParameterType, Value, contractParameter, contractStorage)
import Tezos.Address (Address(..), ContractHash)
import Tezos.Core (ChainId, Mutez, divModMutezInt, dummyChainId)
import Tezos.Crypto
import Util.Aeson
import Util.Lens

-- | State of a contract with code.
data ContractState = ContractState
  { ContractState -> Mutez
csBalance :: Mutez
  -- ^ Amount of mutez owned by this contract.
  , ContractState -> Value
csStorage :: Value
  -- ^ Storage value associated with this contract.
  , ContractState -> Contract
csContract :: Contract
  -- ^ Contract itself (untyped).
  , ContractState -> Maybe SomeContract
csTypedContract :: (Maybe SomeContract)
  , ContractState -> Maybe SomeValue
csTypedStorage :: (Maybe SomeValue)
  -- ^ We keep typed representation of contract code
  -- and storage in form, that hides their actual type
  -- in order to simplify the rest of the code
  -- (e.g. avoid type parameters for `ContractState` and so on).
  -- They are made optional in order to perform safe parsing
  -- from JSON (we simply return `Nothing` in this parser and use
  -- `getTypedStorage` or `getTypedContract` that optionally typecheck
  -- storage or contract code).
  }

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
csStorage
    , "contract" Text -> Contract -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Contract
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
csBalance <- Object
o Object -> Text -> Parser Mutez
forall a. FromJSON a => Object -> Text -> Parser a
.: "balance"
    Value
csStorage <- Object
o Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: "storage"
    Contract
csContract <- Object
o Object -> Text -> Parser Contract
forall a. FromJSON a => Object -> Text -> Parser a
.: "contract"
    let csTypedContract :: Maybe a
csTypedContract = Maybe a
forall a. Maybe a
Nothing
    let csTypedStorage :: Maybe a
csTypedStorage = Maybe a
forall a. Maybe a
Nothing
    return $WContractState :: Mutez
-> Value
-> Contract
-> Maybe SomeContract
-> Maybe SomeValue
-> ContractState
ContractState {..}

instance Buildable ContractState where
  build :: ContractState -> Builder
build ContractState{..} =
    "Contractstate:\n csBalance: " 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  csStorage: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Value
csStorage Value -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+
    "\n  csContract: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Contract
csContract Contract -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+
    "\n  csTypedContract: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Maybe SomeContract
csTypedContract Maybe SomeContract -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+
    "\n  csTypedStorage: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Maybe SomeValue
csTypedStorage Maybe SomeValue -> 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.
  } 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

getTypedContract :: GState -> ContractState -> Either TCError SomeContract
getTypedContract :: GState -> ContractState -> Either TCError SomeContract
getTypedContract gs :: GState
gs ContractState{..} =
  TcOriginatedContracts -> Contract -> Either TCError SomeContract
typeCheckContract (GState -> TcOriginatedContracts
extractAllContracts GState
gs) Contract
csContract

getTypedStorage :: GState -> ContractState -> Either TCError SomeValue
getTypedStorage :: GState -> ContractState -> Either TCError SomeValue
getTypedStorage gs :: GState
gs ContractState{..} =
  HasCallStack =>
TcOriginatedContracts -> Type -> Value -> Either TCError SomeValue
TcOriginatedContracts -> Type -> Value -> Either TCError SomeValue
typeCheckTopLevelType (GState -> TcOriginatedContracts
extractAllContracts GState
gs) (Contract -> Type
forall op. Contract' op -> Type
contractStorage Contract
csContract) Value
csStorage

-- [#36] TODO: try to get rid of this type, 'ContractState' should become
-- broader than it
data SomeContractAndStorage =
  forall cp st. (ParameterScope cp, StorageScope st) => SomeContractAndStorage
  { ()
scsContract :: T.FullContract cp st
  , ()
scsStorage :: T.Value st
  }

getTypedContractAndStorage
  :: (TCError -> err)
  -> (TCError -> err)
  -> GState
  -> ContractState
  -> Either err SomeContractAndStorage
getTypedContractAndStorage :: (TCError -> err)
-> (TCError -> err)
-> GState
-> ContractState
-> Either err SomeContractAndStorage
getTypedContractAndStorage liftContractErr :: TCError -> err
liftContractErr liftStorageErr :: TCError -> err
liftStorageErr gs :: GState
gs cs :: ContractState
cs = do
  SomeContract (contract :: FullContract cp st
contract@T.FullContract{} :: T.FullContract cp st) <-
    (TCError -> err)
-> Either TCError SomeContract -> Either err SomeContract
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TCError -> err
liftContractErr (Either TCError SomeContract -> Either err SomeContract)
-> Either TCError SomeContract -> Either err SomeContract
forall a b. (a -> b) -> a -> b
$ GState -> ContractState -> Either TCError SomeContract
getTypedContract GState
gs ContractState
cs
  SomeValue (Value t
storage :: T.Value st') <-
    (TCError -> err)
-> Either TCError SomeValue -> Either err SomeValue
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TCError -> err
liftStorageErr (Either TCError SomeValue -> Either err SomeValue)
-> Either TCError SomeValue -> Either err SomeValue
forall a b. (a -> b) -> a -> b
$ GState -> ContractState -> Either TCError SomeValue
getTypedStorage GState
gs ContractState
cs
  st :~: t
Refl <- (st :~: t) -> Either err (st :~: t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((st :~: t) -> Either err (st :~: t))
-> (st :~: t) -> Either err (st :~: t)
forall a b. (a -> b) -> a -> b
$ (Typeable st, Typeable t) => Maybe (st :~: t)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @st @st'
              Maybe (st :~: t) -> (st :~: t) -> st :~: t
forall a. Maybe a -> a -> a
?: Text -> st :~: t
forall a. HasCallStack => Text -> a
error "Storage type does not match the contract in runtime state"
  SomeContractAndStorage -> Either err SomeContractAndStorage
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeContractAndStorage -> Either err SomeContractAndStorage)
-> SomeContractAndStorage -> Either err SomeContractAndStorage
forall a b. (a -> b) -> a -> b
$ FullContract cp st -> Value st -> SomeContractAndStorage
forall (cp :: T) (st :: T).
(ParameterScope cp, StorageScope st) =>
FullContract cp st -> Value st -> SomeContractAndStorage
SomeContractAndStorage FullContract cp st
contract Value st
Value t
storage

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

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

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
  = GSAddAddress Address AddressState
  | GSSetStorageValue Address Value SomeValue
  | GSSetBalance Address Mutez
  deriving stock (Int -> GStateUpdate -> ShowS
[GStateUpdate] -> ShowS
GStateUpdate -> String
(Int -> GStateUpdate -> ShowS)
-> (GStateUpdate -> String)
-> ([GStateUpdate] -> ShowS)
-> Show GStateUpdate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GStateUpdate] -> ShowS
$cshowList :: [GStateUpdate] -> ShowS
show :: GStateUpdate -> String
$cshow :: GStateUpdate -> String
showsPrec :: Int -> GStateUpdate -> ShowS
$cshowsPrec :: Int -> GStateUpdate -> ShowS
Show)

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 val :: Value
val _ ->
        "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
val 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
|+ ""

data GStateUpdateError
  = GStateAddressExists Address
  | GStateUnknownAddress Address
  | GStateNotContract 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

-- | 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
newValue newTypedValue :: SomeValue
newTypedValue ->
      Address
-> Value -> SomeValue -> GState -> Either GStateUpdateError GState
setStorageValue Address
addr Value
newValue SomeValue
newTypedValue
    GSSetBalance addr :: Address
addr newBalance :: Mutez
newBalance -> Address -> Mutez -> GState -> Either GStateUpdateError GState
setBalance Address
addr Mutez
newBalance

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

-- | Updare storage value associated with given address.
setStorageValue ::
     Address -> Value -> SomeValue -> GState -> Either GStateUpdateError GState
setStorageValue :: Address
-> Value -> SomeValue -> GState -> Either GStateUpdateError GState
setStorageValue addr :: Address
addr newValue :: Value
newValue newTypedValue :: SomeValue
newTypedValue = Address
-> (AddressState -> Either GStateUpdateError AddressState)
-> GState
-> Either GStateUpdateError GState
updateAddressState Address
addr AddressState -> Either GStateUpdateError AddressState
modifier
  where
    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 cs :: 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 -> AddressState) -> ContractState -> AddressState
forall a b. (a -> b) -> a -> b
$
      ContractState
cs { csStorage :: Value
csStorage = Value
newValue
         , csTypedStorage :: Maybe SomeValue
csTypedStorage = SomeValue -> Maybe SomeValue
forall a. a -> Maybe a
Just SomeValue
newTypedValue
         }

-- | Updare 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, ParameterType)] -> TcOriginatedContracts
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ContractHash, ParameterType)] -> TcOriginatedContracts)
-> (GState -> [(ContractHash, ParameterType)])
-> GState
-> TcOriginatedContracts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Address, AddressState) -> Maybe (ContractHash, ParameterType))
-> [(Address, AddressState)] -> [(ContractHash, ParameterType)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Address, AddressState) -> Maybe (ContractHash, ParameterType)
extractContract ([(Address, AddressState)] -> [(ContractHash, ParameterType)])
-> (GState -> [(Address, AddressState)])
-> GState
-> [(ContractHash, ParameterType)]
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, ParameterType)
    extractContract :: (Address, AddressState) -> Maybe (ContractHash, ParameterType)
extractContract =
      \case (KeyAddress _, ASSimple {}) -> Maybe (ContractHash, ParameterType)
forall a. Maybe a
Nothing
            (KeyAddress _, _) -> Text -> Maybe (ContractHash, ParameterType)
forall a. HasCallStack => Text -> a
error "broken GState"
            (ContractAddress ca :: ContractHash
ca, ASContract cs :: ContractState
cs) ->
              (ContractHash, ParameterType)
-> Maybe (ContractHash, ParameterType)
forall a. a -> Maybe a
Just (ContractHash
ca, Contract -> ParameterType
forall op. Contract' op -> ParameterType
contractParameter (Contract -> ParameterType) -> Contract -> ParameterType
forall a b. (a -> b) -> a -> b
$ ContractState -> Contract
csContract ContractState
cs)
            (ContractAddress _, _) -> Text -> Maybe (ContractHash, ParameterType)
forall a. HasCallStack => Text -> a
error "broken GState"