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

-- | Global blockchain state (emulated).

module Morley.Michelson.Runtime.GState
  (
    -- * Auxiliary types
    ContractState (..)
  , VotingPowers (..)
  , ImplicitState (..)
  , TicketKey (..)
  , toTicketKey
  , isBalanceL
  , isDelegateL
  , isTicketsL
  , vpPick
  , vpTotal
  , mkVotingPowers
  , mkVotingPowersFromMap
  , dummyVotingPowers
  , BigMapCounter(..)
  , bigMapCounter

  -- * GState
  , GState (..)
  , gsChainIdL
  , gsImplicitAddressesL
  , gsContractAddressesL
  , gsImplicitAddressAliasesL
  , gsContractAddressAliasesL
  , gsVotingPowersL
  , gsCounterL
  , gsBigMapCounterL
  , addressesL
  , genesisAddresses
  , genesisKeyHashes
  , genesisAddress
  -- * More genesisAddresses which can be used in tests
  , genesisAddress1
  , genesisAddress2
  , genesisAddress3
  , genesisAddressN
  , genesisKeyHash
  -- * Genesis secret keys
  , genesisSecretKey
  , genesisSecrets

  , initGState
  , readGState
  , writeGState

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

import Control.Lens (at, makeLenses, (?~))
import Data.Aeson
  (FromJSON(..), FromJSONKey, ToJSON(..), ToJSONKey, 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.Constraint ((\\))
import Data.Default (def)
import Data.Map.Strict qualified as Map
import Data.Type.Equality ((:~:)(..))
import Fmt (Buildable(build), nameF, pretty, unlinesF, (+|), (|+))
import System.IO.Error (IOError, isDoesNotExistError)

import Morley.Michelson.TypeCheck
  (SomeParamType(..), TcOriginatedContracts, tcStrict, 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.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Address.Alias
import Morley.Tezos.Address.Kinds
import Morley.Tezos.Core (ChainId, Mutez, divModMutezInt, dummyChainId)
import Morley.Tezos.Crypto
import Morley.Util.Aeson
import Morley.Util.Bimap (Bimap)
import Morley.Util.Bimap qualified as Bimap
import Morley.Util.Lens
import Morley.Util.Named
import Morley.Util.Peano (ToPeano, type (>))
import Morley.Util.Sing (eqI, eqParamSing, eqParamSing2)
import Morley.Util.SizedList qualified as SL
import Morley.Util.SizedList.Types

data ImplicitState = ImplicitState
  { ImplicitState -> Mutez
isBalance :: Mutez
    -- ^ Implicit address balance.
  , ImplicitState -> HashMap TicketKey Natural
isTickets :: HashMap TicketKey Natural
    -- ^ Implicit account's ticket balances.
  , ImplicitState -> Maybe KeyHash
isDelegate :: Maybe KeyHash
    -- ^ Delegate, if set. Implicit address can have a delegate set to itself,
    -- then it's considered "registered delegate" and can be set as delegate for
    -- other addresses. It's impossible to "unregister" a delegate, so once
    -- delegate is set to the address itself, it can't be changed.
  } deriving stock (Int -> ImplicitState -> ShowS
[ImplicitState] -> ShowS
ImplicitState -> String
(Int -> ImplicitState -> ShowS)
-> (ImplicitState -> String)
-> ([ImplicitState] -> ShowS)
-> Show ImplicitState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ImplicitState -> ShowS
showsPrec :: Int -> ImplicitState -> ShowS
$cshow :: ImplicitState -> String
show :: ImplicitState -> String
$cshowList :: [ImplicitState] -> ShowS
showList :: [ImplicitState] -> ShowS
Show, ImplicitState -> ImplicitState -> Bool
(ImplicitState -> ImplicitState -> Bool)
-> (ImplicitState -> ImplicitState -> Bool) -> Eq ImplicitState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ImplicitState -> ImplicitState -> Bool
== :: ImplicitState -> ImplicitState -> Bool
$c/= :: ImplicitState -> ImplicitState -> Bool
/= :: ImplicitState -> ImplicitState -> Bool
Eq)

-- | A triple of ticketer, value and type, which uniquely defines a ticket.
newtype TicketKey = TicketKey (Address, U.Value, U.Ty)
  deriving newtype (TicketKey -> TicketKey -> Bool
(TicketKey -> TicketKey -> Bool)
-> (TicketKey -> TicketKey -> Bool) -> Eq TicketKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TicketKey -> TicketKey -> Bool
== :: TicketKey -> TicketKey -> Bool
$c/= :: TicketKey -> TicketKey -> Bool
/= :: TicketKey -> TicketKey -> Bool
Eq, Int -> TicketKey -> ShowS
[TicketKey] -> ShowS
TicketKey -> String
(Int -> TicketKey -> ShowS)
-> (TicketKey -> String)
-> ([TicketKey] -> ShowS)
-> Show TicketKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TicketKey -> ShowS
showsPrec :: Int -> TicketKey -> ShowS
$cshow :: TicketKey -> String
show :: TicketKey -> String
$cshowList :: [TicketKey] -> ShowS
showList :: [TicketKey] -> ShowS
Show, [TicketKey] -> Value
[TicketKey] -> Encoding
TicketKey -> Value
TicketKey -> Encoding
(TicketKey -> Value)
-> (TicketKey -> Encoding)
-> ([TicketKey] -> Value)
-> ([TicketKey] -> Encoding)
-> ToJSON TicketKey
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: TicketKey -> Value
toJSON :: TicketKey -> Value
$ctoEncoding :: TicketKey -> Encoding
toEncoding :: TicketKey -> Encoding
$ctoJSONList :: [TicketKey] -> Value
toJSONList :: [TicketKey] -> Value
$ctoEncodingList :: [TicketKey] -> Encoding
toEncodingList :: [TicketKey] -> Encoding
ToJSON, Value -> Parser [TicketKey]
Value -> Parser TicketKey
(Value -> Parser TicketKey)
-> (Value -> Parser [TicketKey]) -> FromJSON TicketKey
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser TicketKey
parseJSON :: Value -> Parser TicketKey
$cparseJSONList :: Value -> Parser [TicketKey]
parseJSONList :: Value -> Parser [TicketKey]
FromJSON, FromJSONKeyFunction [TicketKey]
FromJSONKeyFunction TicketKey
FromJSONKeyFunction TicketKey
-> FromJSONKeyFunction [TicketKey] -> FromJSONKey TicketKey
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
$cfromJSONKey :: FromJSONKeyFunction TicketKey
fromJSONKey :: FromJSONKeyFunction TicketKey
$cfromJSONKeyList :: FromJSONKeyFunction [TicketKey]
fromJSONKeyList :: FromJSONKeyFunction [TicketKey]
FromJSONKey, ToJSONKeyFunction [TicketKey]
ToJSONKeyFunction TicketKey
ToJSONKeyFunction TicketKey
-> ToJSONKeyFunction [TicketKey] -> ToJSONKey TicketKey
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
$ctoJSONKey :: ToJSONKeyFunction TicketKey
toJSONKey :: ToJSONKeyFunction TicketKey
$ctoJSONKeyList :: ToJSONKeyFunction [TicketKey]
toJSONKeyList :: ToJSONKeyFunction [TicketKey]
ToJSONKey)

instance Buildable TicketKey where
  build :: TicketKey -> Doc
build (TicketKey (Address
addr, Value
val, Ty
ty)) =
    Doc
"(" Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Address
addr Address -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
", " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Value
val Value -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
", " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Ty
ty Ty -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
")"

instance Hashable TicketKey where
  hashWithSalt :: Int -> TicketKey -> Int
hashWithSalt Int
s = Int -> Value -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Value -> Int) -> (TicketKey -> Value) -> TicketKey -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TicketKey -> Value
forall a. ToJSON a => a -> Value
toJSON

-- | Convert a typed ticket value to 'TicketKey' and amount.
toTicketKey :: forall t. T.Value ('T.TTicket t) -> (TicketKey, Natural)
toTicketKey :: forall (t :: T). Value ('TTicket t) -> (TicketKey, Natural)
toTicketKey (T.VTicket Address
ticketer Value' Instr arg
value Natural
amount) =
  ((Address, Value, Ty) -> TicketKey
TicketKey (Address
ticketer, Value' Instr arg -> Value
forall (t :: T). ForbidOp t => Value' Instr t -> Value
T.untypeValue Value' Instr arg
value, Notes t -> Ty
forall (x :: T). Notes x -> Ty
T.mkUType (Notes t -> Ty) -> Notes t -> Ty
forall a b. (a -> b) -> a -> b
$ forall (t :: T). SingI t => Notes t
T.starNotes @t), Natural
amount)
  (SingI t => (TicketKey, Natural))
-> Dict (SingI arg) -> (TicketKey, Natural)
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ Value' Instr arg -> Dict (SingI arg)
forall (instr :: [T] -> [T] -> *) (t :: T).
Value' instr t -> Dict (SingI t)
T.valueTypeSanity Value' Instr arg
value
  ((ForbidOp t, ForbidNestedBigMaps t, ForbidTicket t,
  ForbidSaplingState t, ForbidBigMap t, ForbidContract t,
  ForbidNonComparable t) =>
 (TicketKey, Natural))
-> Dict
     (ForbidOp t, ForbidNestedBigMaps t, ForbidTicket t,
      ForbidSaplingState t, ForbidBigMap t, ForbidContract t,
      ForbidNonComparable t)
-> (TicketKey, Natural)
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ Proxy t
-> Dict
     (ForbidOp t, ForbidNestedBigMaps t, ForbidTicket t,
      ForbidSaplingState t, ForbidBigMap t, ForbidContract t,
      ForbidNonComparable t)
forall (t :: T) (proxy :: T -> *).
ForbidNonComparable t =>
proxy t -> Dict (ComparabilityImplies t)
T.comparableImplies (forall {k} (t :: k). Proxy t
forall (t :: T). Proxy t
Proxy @t)

deriveJSON morleyAesonOptions ''ImplicitState
makeLensesWith postfixLFields ''ImplicitState

instance Buildable ImplicitState where
  build :: ImplicitState -> Doc
build ImplicitState{Maybe KeyHash
HashMap TicketKey Natural
Mutez
isBalance :: ImplicitState -> Mutez
isTickets :: ImplicitState -> HashMap TicketKey Natural
isDelegate :: ImplicitState -> Maybe KeyHash
isBalance :: Mutez
isTickets :: HashMap TicketKey Natural
isDelegate :: Maybe KeyHash
..} = Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Implicit state" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Doc
unlinesF
    [ Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Balance" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Mutez -> Doc
forall a. Buildable a => a -> Doc
build Mutez
isBalance
    , Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Delegate" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Maybe KeyHash -> Doc
forall a. Buildable a => a -> Doc
build Maybe KeyHash
isDelegate
    ]

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

makeLensesWith postfixLFields ''ContractState

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
csBalance :: ContractState -> Mutez
csContract :: ()
csStorage :: ()
csDelegate :: ContractState -> Maybe KeyHash
csBalance :: Mutez
csContract :: Contract cp st
csStorage :: Value st
csDelegate :: Maybe KeyHash
..} =
    [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
. (Key
"delegate" Key -> KeyHash -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.=)) Maybe KeyHash
csDelegate ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
    [ Key
"balance" Key -> Mutez -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Mutez
csBalance
    , Key
"storage" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Value st -> Value
forall (t :: T). ForbidOp t => Value' Instr t -> Value
T.untypeValue Value st
csStorage
    , Key
"contract" Key -> Contract -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= 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 -> Key -> Parser Mutez
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"balance"
      (Value
uStorage :: Value) <- Object
o Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"storage"
      (Contract
uContract :: Contract) <- Object
o Object -> Key -> Parser Contract
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contract"
      (Maybe KeyHash
delegate :: Maybe KeyHash) <- Object
o Object -> Key -> Parser (Maybe KeyHash)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"delegate"
      case TypeCheckOptions
-> TypeCheckResult ExpandedOp SomeContractAndStorage
-> Either (TcError' ExpandedOp) SomeContractAndStorage
forall op a.
TypeCheckOptions -> TypeCheckResult op a -> Either (TcError' op) a
typeCheckingWith TypeCheckOptions
forall a. Default a => a
def{ tcStrict :: Bool
tcStrict=Bool
False } (TypeCheckResult ExpandedOp SomeContractAndStorage
 -> Either (TcError' ExpandedOp) SomeContractAndStorage)
-> TypeCheckResult ExpandedOp SomeContractAndStorage
-> Either (TcError' ExpandedOp) SomeContractAndStorage
forall a b. (a -> b) -> a -> b
$ Contract
-> Value -> TypeCheckResult ExpandedOp SomeContractAndStorage
typeCheckContractAndStorage Contract
uContract Value
uStorage of
        Right (SomeContractAndStorage Contract cp st
contract Value st
storage) ->
          ContractState -> Parser ContractState
forall a. a -> Parser a
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' ExpandedOp
err -> String -> Parser ContractState
forall a. String -> Parser a
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' ExpandedOp -> String
forall a b. (Buildable a, FromDoc b) => a -> b
pretty TcError' ExpandedOp
err

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

-- | 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
$cshowsPrec :: Int -> VotingPowers -> ShowS
showsPrec :: Int -> VotingPowers -> ShowS
$cshow :: VotingPowers -> String
show :: VotingPowers -> String
$cshowList :: [VotingPowers] -> ShowS
showList :: [VotingPowers] -> ShowS
Show, VotingPowers -> VotingPowers -> Bool
(VotingPowers -> VotingPowers -> Bool)
-> (VotingPowers -> VotingPowers -> Bool) -> Eq VotingPowers
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VotingPowers -> VotingPowers -> Bool
== :: VotingPowers -> VotingPowers -> Bool
$c/= :: VotingPowers -> VotingPowers -> Bool
/= :: 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
$cshowsPrec :: Int -> BigMapCounter -> ShowS
showsPrec :: Int -> BigMapCounter -> ShowS
$cshow :: BigMapCounter -> String
show :: BigMapCounter -> String
$cshowList :: [BigMapCounter] -> ShowS
showList :: [BigMapCounter] -> ShowS
Show, BigMapCounter -> BigMapCounter -> Bool
(BigMapCounter -> BigMapCounter -> Bool)
-> (BigMapCounter -> BigMapCounter -> Bool) -> Eq BigMapCounter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BigMapCounter -> BigMapCounter -> Bool
== :: BigMapCounter -> BigMapCounter -> Bool
$c/= :: BigMapCounter -> BigMapCounter -> Bool
/= :: 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
$cfrom :: forall x. BigMapCounter -> Rep BigMapCounter x
from :: forall x. BigMapCounter -> Rep BigMapCounter x
$cto :: forall x. Rep BigMapCounter x -> BigMapCounter
to :: forall x. Rep BigMapCounter x -> BigMapCounter
Generic)
  deriving anyclass (BigMapCounter -> ()
(BigMapCounter -> ()) -> NFData BigMapCounter
forall a. (a -> ()) -> NFData a
$crnf :: BigMapCounter -> ()
rnf :: BigMapCounter -> ()
NFData)
  deriving newtype ([BigMapCounter] -> Value
[BigMapCounter] -> Encoding
BigMapCounter -> Value
BigMapCounter -> Encoding
(BigMapCounter -> Value)
-> (BigMapCounter -> Encoding)
-> ([BigMapCounter] -> Value)
-> ([BigMapCounter] -> Encoding)
-> ToJSON BigMapCounter
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: BigMapCounter -> Value
toJSON :: BigMapCounter -> Value
$ctoEncoding :: BigMapCounter -> Encoding
toEncoding :: BigMapCounter -> Encoding
$ctoJSONList :: [BigMapCounter] -> Value
toJSONList :: [BigMapCounter] -> Value
$ctoEncodingList :: [BigMapCounter] -> Encoding
toEncodingList :: [BigMapCounter] -> Encoding
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
$cparseJSON :: Value -> Parser BigMapCounter
parseJSON :: Value -> Parser BigMapCounter
$cparseJSONList :: Value -> Parser [BigMapCounter]
parseJSONList :: 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
$c+ :: BigMapCounter -> BigMapCounter -> BigMapCounter
+ :: BigMapCounter -> BigMapCounter -> BigMapCounter
$c- :: BigMapCounter -> BigMapCounter -> BigMapCounter
- :: BigMapCounter -> BigMapCounter -> BigMapCounter
$c* :: BigMapCounter -> BigMapCounter -> BigMapCounter
* :: BigMapCounter -> BigMapCounter -> BigMapCounter
$cnegate :: BigMapCounter -> BigMapCounter
negate :: BigMapCounter -> BigMapCounter
$cabs :: BigMapCounter -> BigMapCounter
abs :: BigMapCounter -> BigMapCounter
$csignum :: BigMapCounter -> BigMapCounter
signum :: BigMapCounter -> BigMapCounter
$cfromInteger :: Integer -> BigMapCounter
fromInteger :: Integer -> BigMapCounter
Num, [BigMapCounter] -> Doc
BigMapCounter -> Doc
(BigMapCounter -> Doc)
-> ([BigMapCounter] -> Doc) -> Buildable BigMapCounter
forall a. (a -> Doc) -> ([a] -> Doc) -> Buildable a
$cbuild :: BigMapCounter -> Doc
build :: BigMapCounter -> Doc
$cbuildList :: [BigMapCounter] -> Doc
buildList :: [BigMapCounter] -> Doc
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 ImplicitAddress ImplicitState
gsImplicitAddresses :: Map ImplicitAddress ImplicitState
  -- ^ All known implicit addresses and their state (i.e. balance)
  , GState -> Map ContractAddress ContractState
gsContractAddresses :: Map ContractAddress ContractState
  -- ^ All known contract addresses and their state.
  , GState -> Map SmartRollupAddress ()
gsSmartRollupAddresses :: Map SmartRollupAddress ()
  -- ^ All known smart rollup addresses and their state.
  , GState -> VotingPowers
gsVotingPowers :: VotingPowers
  -- ^ Voting power distribution.
  , GState -> GlobalCounter
gsCounter :: GlobalCounter
  -- ^ Ever increasing operation counter.
  , GState -> BigMapCounter
gsBigMapCounter :: BigMapCounter
  , GState -> Bimap ImplicitAlias ImplicitAddress
gsImplicitAddressAliases :: Bimap ImplicitAlias ImplicitAddress
  -- ^ Implicit addresses with the associated aliases/names.
  , GState -> Bimap ContractAlias ContractAddress
gsContractAddressAliases :: Bimap ContractAlias ContractAddress
  -- ^ Contract addresses with the associated aliases/names.
  } 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
$cshowsPrec :: Int -> GState -> ShowS
showsPrec :: Int -> GState -> ShowS
$cshow :: GState -> String
show :: GState -> String
$cshowList :: [GState] -> ShowS
showList :: [GState] -> ShowS
Show, GState -> GState -> Bool
(GState -> GState -> Bool)
-> (GState -> GState -> Bool) -> Eq GState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GState -> GState -> Bool
== :: GState -> GState -> Bool
$c/= :: GState -> GState -> Bool
/= :: 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 = forall (n :: Natural) (proxy :: Natural -> *).
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 :: Natural) (n' :: Peano) a.
(SingIPeano n, IsoNatPeano n n') =>
(Natural -> a) -> SizedList' n' 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 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 ImplicitAddress
genesisAddresses :: GenesisList ImplicitAddress
genesisAddresses = KeyHash -> ImplicitAddress
ImplicitAddress (KeyHash -> ImplicitAddress)
-> 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))))))))))
     ImplicitAddress
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 :: ImplicitAddress
genesisAddress :: ImplicitAddress
genesisAddress = SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))
  ImplicitAddress
-> ImplicitAddress
forall (n :: Peano) a. SizedList' ('S n) a -> a
SL.head SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))
  ImplicitAddress
GenesisList ImplicitAddress
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 :: ImplicitAddress
ImplicitAddress
_ :< ImplicitAddress
genesisAddress1 :< ImplicitAddress
genesisAddress2 :< ImplicitAddress
genesisAddress3
  :< SizedList' n1 ImplicitAddress
_ = SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))
  ImplicitAddress
GenesisList ImplicitAddress
genesisAddresses

-- | 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)
  => ImplicitAddress
genesisAddressN :: forall (n :: Natural).
(SingIPeano n,
 (ToPeano GenesisAddressesNum > ToPeano n) ~ 'True) =>
ImplicitAddress
genesisAddressN = forall (i :: Natural) (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))))))))))
  ImplicitAddress
GenesisList ImplicitAddress
genesisAddresses

-- | Dummy 'VotingPowers'. We give all the voting power to two genesis addresses
-- 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' n1 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
  { gsChainId :: ChainId
gsChainId = ChainId
dummyChainId
  , gsImplicitAddresses :: Map ImplicitAddress ImplicitState
gsImplicitAddresses = [(ImplicitAddress, ImplicitState)]
-> Map ImplicitAddress ImplicitState
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (ImplicitAddress
genesis, Mutez
-> HashMap TicketKey Natural -> Maybe KeyHash -> ImplicitState
ImplicitState Mutez
money HashMap TicketKey Natural
forall a. Monoid a => a
mempty Maybe KeyHash
forall a. Maybe a
Nothing)
    | let (Mutez
money, 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"
    , ImplicitAddress
genesis <- SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))
  ImplicitAddress
-> [Element
      (SizedList'
         ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))
         ImplicitAddress)]
forall t. Container t => t -> [Element t]
toList SizedList'
  ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))
  ImplicitAddress
GenesisList ImplicitAddress
genesisAddresses
    ]
  , gsContractAddresses :: Map ContractAddress ContractState
gsContractAddresses = Map ContractAddress ContractState
forall k a. Map k a
Map.empty
  , gsSmartRollupAddresses :: Map SmartRollupAddress ()
gsSmartRollupAddresses = Map SmartRollupAddress ()
forall k a. Map k a
Map.empty
  , gsVotingPowers :: VotingPowers
gsVotingPowers = VotingPowers
dummyVotingPowers
  , gsCounter :: GlobalCounter
gsCounter = Word64 -> GlobalCounter
GlobalCounter Word64
0
  , gsBigMapCounter :: BigMapCounter
gsBigMapCounter = Natural -> BigMapCounter
BigMapCounter Natural
0
  , gsImplicitAddressAliases :: Bimap ImplicitAlias ImplicitAddress
gsImplicitAddressAliases = Bimap ImplicitAlias ImplicitAddress
forall a b. Bimap a b
Bimap.empty
  , gsContractAddressAliases :: Bimap ContractAlias ContractAddress
gsContractAddressAliases = Bimap ContractAlias ContractAddress
forall a b. Bimap a b
Bimap.empty
  }

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
$cshowsPrec :: Int -> GStateParseError -> ShowS
showsPrec :: Int -> GStateParseError -> ShowS
$cshow :: GStateParseError -> String
show :: GStateParseError -> String
$cshowList :: [GStateParseError] -> ShowS
showList :: [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 LByteString
LBS.readFile String
fp IO LByteString -> (LByteString -> IO GState) -> IO GState
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LByteString -> 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 :: LByteString -> IO GState
parseFile LByteString
lByteString =
      if LByteString -> Bool
forall t. Container t => t -> Bool
null LByteString
lByteString
      then GState -> IO GState
forall a. a -> IO a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String GState -> IO GState)
-> (LByteString -> Either String GState)
-> LByteString
-> IO GState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LByteString -> Either String GState
forall a. FromJSON a => LByteString -> Either String a
Aeson.eitherDecode') LByteString
lByteString
    onExc :: IOError -> IO GState
    onExc :: IOError -> IO GState
onExc IOError
exc
      | IOError -> Bool
isDoesNotExistError IOError
exc = GState -> IO GState
forall a. a -> IO a
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 -> LByteString -> IO ()
LBS.writeFile String
fp (Config -> GState -> LByteString
forall a. ToJSON a => Config -> a -> LByteString
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
  GSAddImplicitAddress :: ImplicitAddress -> Mutez -> [(TicketKey, Natural)] -> GStateUpdate
  GSAddContractAddress :: ContractAddress -> ContractState -> GStateUpdate
  GSAddContractAddressAlias :: ContractAlias -> ContractAddress -> GStateUpdate
  GSSetStorageValue :: StorageScope st => ContractAddress -> T.Value st -> GStateUpdate
  GSSetBalance :: L1AddressKind kind => KindedAddress kind -> Mutez -> GStateUpdate
  GSAddTickets :: ImplicitAddress -> TicketKey -> Natural -> GStateUpdate
  GSRemoveTickets :: ImplicitAddress -> TicketKey -> Natural -> GStateUpdate
  GSIncrementCounter :: GStateUpdate
  GSUpdateCounter :: GlobalCounter -> GStateUpdate
  GSSetBigMapCounter :: BigMapCounter -> GStateUpdate
  GSSetDelegate :: L1AddressKind kind => KindedAddress kind -> Maybe KeyHash -> GStateUpdate

deriving stock instance Show GStateUpdate

instance Buildable GStateUpdate where
  build :: GStateUpdate -> Doc
build =
    \case
      GSAddImplicitAddress ImplicitAddress
addr Mutez
st [(TicketKey, Natural)]
_ ->
        Doc
"Add implicit address " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ImplicitAddress
addr ImplicitAddress -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" with balance " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Mutez
st Mutez -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
      GSAddContractAddress ContractAddress
addr ContractState
st ->
        Doc
"Add contract address " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ContractAddress
addr ContractAddress -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" with state " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ContractState
st ContractState -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
      GSAddContractAddressAlias ContractAlias
alias ContractAddress
addr ->
        Doc
"Add an alias " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ContractAlias
alias ContractAlias -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" for address " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ContractAddress
addr ContractAddress -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
      GSSetStorageValue ContractAddress
addr Value st
tVal ->
        Doc
"Set storage value of address " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ContractAddress
addr ContractAddress -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" to " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Value st -> Value
forall (t :: T). ForbidOp t => Value' Instr t -> Value
T.untypeValue Value st
tVal Value -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
      GSSetBalance KindedAddress kind
addr Mutez
balance ->
        Doc
"Set balance of address " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| KindedAddress kind
addr KindedAddress kind -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" to " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Mutez
balance Mutez -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
      GStateUpdate
GSIncrementCounter ->
        Doc
"Increment internal counter after operation"
      GSUpdateCounter GlobalCounter
v ->
        Doc
"Set internal counter to " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| GlobalCounter
v GlobalCounter -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" after interpreting " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
        Doc
"several 'CREATE_CONTRACT' instructions"
      GSSetBigMapCounter BigMapCounter
inc ->
        Doc
"Increment internal big_map counter by: " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| BigMapCounter -> Doc
forall a. Buildable a => a -> Doc
build BigMapCounter
inc
      GSSetDelegate KindedAddress kind
addr Maybe KeyHash
key ->
        Doc
"Set delegate for " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| KindedAddress kind
addr KindedAddress kind -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" to " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Doc -> (KeyHash -> Doc) -> Maybe KeyHash -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
"<nobody>" KeyHash -> Doc
forall a. Buildable a => a -> Doc
build Maybe KeyHash
key
      GSAddTickets ImplicitAddress
addr TicketKey
key Natural
amount ->
        Doc
"Add " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Natural
amount Natural -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" tickets to " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ImplicitAddress
addr ImplicitAddress -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" type " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| TicketKey
key TicketKey -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
      GSRemoveTickets ImplicitAddress
addr TicketKey
key Natural
amount ->
        Doc
"Remove " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Natural
amount Natural -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" tickets from " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ImplicitAddress
addr ImplicitAddress -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" type " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| TicketKey
key TicketKey -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""

data GStateUpdateError
  = GStateAddressExists Address
  | GStateUnknownAddress Address
  | GStateStorageNotMatch ContractAddress
  | GStateNotDelegate ImplicitAddress
  | GStateCantDeleteDelegate ImplicitAddress
  | GStateNoBLSDelegate Address KeyHash
  | GStateAlreadySetDelegate L1Address (Maybe KeyHash)
  | GStateInsufficientTickets ImplicitAddress TicketKey ("needs" :! Natural) ("has" :! Natural)
  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
$cshowsPrec :: Int -> GStateUpdateError -> ShowS
showsPrec :: Int -> GStateUpdateError -> ShowS
$cshow :: GStateUpdateError -> String
show :: GStateUpdateError -> String
$cshowList :: [GStateUpdateError] -> ShowS
showList :: [GStateUpdateError] -> ShowS
Show)

instance Buildable GStateUpdateError where
  build :: GStateUpdateError -> Doc
build = \case
    GStateAddressExists Address
addr -> Doc
"Address already exists: " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Address -> Doc
forall a. Buildable a => a -> Doc
build Address
addr
    GStateUnknownAddress Address
addr -> Doc
"Unknown address: " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Address -> Doc
forall a. Buildable a => a -> Doc
build Address
addr
    GStateStorageNotMatch ContractAddress
addr ->
      Doc
"Storage type does not match the contract in run-time state\
      \ when updating new storage value to address: " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ContractAddress -> Doc
forall a. Buildable a => a -> Doc
build ContractAddress
addr
    GStateNotDelegate ImplicitAddress
addr -> Doc
"Address " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ImplicitAddress
addr ImplicitAddress -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" is not registered as delegate."
    GStateNoBLSDelegate Address
addr KeyHash
kh ->
      Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF (Doc
"Can not set delegate for " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Address
addr Address -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"") (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"tz4 addresses can't be delegates" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
          KeyHash -> Doc
forall a. Buildable a => a -> Doc
build KeyHash
kh
    GStateCantDeleteDelegate ImplicitAddress
addr ->
      Doc
"Delegate deletion is forbidden for " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ImplicitAddress
addr ImplicitAddress -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
    GStateAlreadySetDelegate L1Address
addr Maybe KeyHash
kh ->
      Doc
"Already set delegate for " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| L1Address
addr L1Address -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" to " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> (KeyHash -> Doc) -> Maybe KeyHash -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
"<nothing>" KeyHash -> Doc
forall a. Buildable a => a -> Doc
build Maybe KeyHash
kh
    GStateInsufficientTickets ImplicitAddress
addr TicketKey
key (Name "needs" -> NamedF Identity Natural "needs" -> Natural
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg Name "needs"
#needs -> Natural
needs) (Name "has" -> NamedF Identity Natural "has" -> Natural
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg Name "has"
#has -> Natural
has) ->
      Doc
"Address " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ImplicitAddress
addr ImplicitAddress -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"does not have enough tickets of type " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| TicketKey
key TicketKey -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
": has " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Natural
has
        Natural -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
", needs " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Natural
needs Natural -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""

-- | Apply 'GStateUpdate' to 'GState'.
applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState
applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState
applyUpdate =
  \case
    GSAddImplicitAddress ImplicitAddress
addr Mutez
st [(TicketKey, Natural)]
tickets -> ImplicitAddress
-> Mutez
-> [(TicketKey, Natural)]
-> GState
-> Either GStateUpdateError GState
addImplicitAddress ImplicitAddress
addr Mutez
st [(TicketKey, Natural)]
tickets
    GSAddContractAddress ContractAddress
addr ContractState
st -> ContractAddress
-> ContractState -> GState -> Either GStateUpdateError GState
addContractAddress ContractAddress
addr ContractState
st
    GSAddContractAddressAlias ContractAlias
alias ContractAddress
addr -> 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
. ContractAlias -> ContractAddress -> GState -> GState
addContractAddressAlias ContractAlias
alias ContractAddress
addr
    GSSetStorageValue ContractAddress
addr Value st
newValue ->
      ContractAddress
-> Value st -> GState -> Either GStateUpdateError GState
forall (st :: T).
StorageScope st =>
ContractAddress
-> Value st -> GState -> Either GStateUpdateError GState
setStorageValue ContractAddress
addr Value st
newValue
    GSSetBalance KindedAddress kind
addr Mutez
newBalance -> KindedAddress kind
addr KindedAddress kind
-> Mutez -> GState -> Either GStateUpdateError GState
forall (kind :: AddressKind).
L1AddressKind kind =>
KindedAddress kind
-> Mutez -> GState -> Either GStateUpdateError GState
`setBalance` 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 KindedAddress kind
addr Maybe KeyHash
key -> KindedAddress kind
-> Maybe KeyHash -> GState -> Either GStateUpdateError GState
forall (kind :: AddressKind).
L1AddressKind kind =>
KindedAddress kind
-> Maybe KeyHash -> GState -> Either GStateUpdateError GState
setDelegate KindedAddress kind
addr Maybe KeyHash
key
    GSAddTickets ImplicitAddress
addr TicketKey
key Natural
amount -> ImplicitAddress
-> TicketKey
-> Natural
-> GState
-> Either GStateUpdateError GState
addTickets ImplicitAddress
addr TicketKey
key Natural
amount
    GSRemoveTickets ImplicitAddress
addr TicketKey
key Natural
amount -> ImplicitAddress
-> TicketKey
-> Natural
-> GState
-> Either GStateUpdateError GState
removeTickets ImplicitAddress
addr TicketKey
key Natural
amount

-- | Update ticket balance value associated with given address.
addTickets
  :: ImplicitAddress
  -> TicketKey
  -> Natural
  -> GState
  -> Either GStateUpdateError GState
addTickets :: ImplicitAddress
-> TicketKey
-> Natural
-> GState
-> Either GStateUpdateError GState
addTickets ImplicitAddress
addr TicketKey
key Natural
num = ImplicitAddress
-> (AddressStateFam 'AddressKindImplicit
    -> Either GStateUpdateError (AddressStateFam 'AddressKindImplicit))
-> GState
-> Either GStateUpdateError GState
forall (kind :: AddressKind).
KindedAddress kind
-> (AddressStateFam kind
    -> Either GStateUpdateError (AddressStateFam kind))
-> GState
-> Either GStateUpdateError GState
updateAddressState ImplicitAddress
addr ((AddressStateFam 'AddressKindImplicit
  -> Either GStateUpdateError (AddressStateFam 'AddressKindImplicit))
 -> GState -> Either GStateUpdateError GState)
-> (AddressStateFam 'AddressKindImplicit
    -> Either GStateUpdateError (AddressStateFam 'AddressKindImplicit))
-> GState
-> Either GStateUpdateError GState
forall a b. (a -> b) -> a -> b
$
  ImplicitState -> Either GStateUpdateError ImplicitState
forall a b. b -> Either a b
Right (ImplicitState -> Either GStateUpdateError ImplicitState)
-> (ImplicitState -> ImplicitState)
-> ImplicitState
-> Either GStateUpdateError ImplicitState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HashMap TicketKey Natural -> Identity (HashMap TicketKey Natural))
-> ImplicitState -> Identity ImplicitState
Lens' ImplicitState (HashMap TicketKey Natural)
isTicketsL ((HashMap TicketKey Natural
  -> Identity (HashMap TicketKey Natural))
 -> ImplicitState -> Identity ImplicitState)
-> ((Maybe Natural -> Identity (Maybe Natural))
    -> HashMap TicketKey Natural
    -> Identity (HashMap TicketKey Natural))
-> (Maybe Natural -> Identity (Maybe Natural))
-> ImplicitState
-> Identity ImplicitState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap TicketKey Natural)
-> Lens'
     (HashMap TicketKey Natural)
     (Maybe (IxValue (HashMap TicketKey Natural)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap TicketKey Natural)
TicketKey
key ((Maybe Natural -> Identity (Maybe Natural))
 -> ImplicitState -> Identity ImplicitState)
-> (Maybe Natural -> Maybe Natural)
-> ImplicitState
-> ImplicitState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Natural -> Maybe Natural)
-> (Maybe Natural -> Natural) -> Maybe Natural -> Maybe Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> (Natural -> Natural) -> Maybe Natural -> Natural
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Natural
num (Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
num))

-- | Update ticket balance value associated with given address.
removeTickets
  :: ImplicitAddress
  -> TicketKey
  -> Natural
  -> GState
  -> Either GStateUpdateError GState
removeTickets :: ImplicitAddress
-> TicketKey
-> Natural
-> GState
-> Either GStateUpdateError GState
removeTickets ImplicitAddress
addr TicketKey
key Natural
num = ImplicitAddress
-> (AddressStateFam 'AddressKindImplicit
    -> Either GStateUpdateError (AddressStateFam 'AddressKindImplicit))
-> GState
-> Either GStateUpdateError GState
forall (kind :: AddressKind).
KindedAddress kind
-> (AddressStateFam kind
    -> Either GStateUpdateError (AddressStateFam kind))
-> GState
-> Either GStateUpdateError GState
updateAddressState ImplicitAddress
addr \AddressStateFam 'AddressKindImplicit
st ->
  case ImplicitState
AddressStateFam 'AddressKindImplicit
st ImplicitState
-> Getting (Maybe Natural) ImplicitState (Maybe Natural)
-> Maybe Natural
forall s a. s -> Getting a s a -> a
^. (HashMap TicketKey Natural
 -> Const (Maybe Natural) (HashMap TicketKey Natural))
-> ImplicitState -> Const (Maybe Natural) ImplicitState
Lens' ImplicitState (HashMap TicketKey Natural)
isTicketsL ((HashMap TicketKey Natural
  -> Const (Maybe Natural) (HashMap TicketKey Natural))
 -> ImplicitState -> Const (Maybe Natural) ImplicitState)
-> ((Maybe Natural -> Const (Maybe Natural) (Maybe Natural))
    -> HashMap TicketKey Natural
    -> Const (Maybe Natural) (HashMap TicketKey Natural))
-> Getting (Maybe Natural) ImplicitState (Maybe Natural)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap TicketKey Natural)
-> Lens'
     (HashMap TicketKey Natural)
     (Maybe (IxValue (HashMap TicketKey Natural)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap TicketKey Natural)
TicketKey
key of
    Just Natural
n | Natural
n Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
num -> AddressStateFam 'AddressKindImplicit
-> Either GStateUpdateError (AddressStateFam 'AddressKindImplicit)
forall a b. b -> Either a b
Right (AddressStateFam 'AddressKindImplicit
 -> Either GStateUpdateError (AddressStateFam 'AddressKindImplicit))
-> AddressStateFam 'AddressKindImplicit
-> Either GStateUpdateError (AddressStateFam 'AddressKindImplicit)
forall a b. (a -> b) -> a -> b
$ ImplicitState
AddressStateFam 'AddressKindImplicit
st ImplicitState -> (ImplicitState -> ImplicitState) -> ImplicitState
forall a b. a -> (a -> b) -> b
& (HashMap TicketKey Natural -> Identity (HashMap TicketKey Natural))
-> ImplicitState -> Identity ImplicitState
Lens' ImplicitState (HashMap TicketKey Natural)
isTicketsL ((HashMap TicketKey Natural
  -> Identity (HashMap TicketKey Natural))
 -> ImplicitState -> Identity ImplicitState)
-> ((Maybe Natural -> Identity (Maybe Natural))
    -> HashMap TicketKey Natural
    -> Identity (HashMap TicketKey Natural))
-> (Maybe Natural -> Identity (Maybe Natural))
-> ImplicitState
-> Identity ImplicitState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap TicketKey Natural)
-> Lens'
     (HashMap TicketKey Natural)
     (Maybe (IxValue (HashMap TicketKey Natural)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap TicketKey Natural)
TicketKey
key ((Maybe Natural -> Identity (Maybe Natural))
 -> ImplicitState -> Identity ImplicitState)
-> Maybe Natural -> ImplicitState -> ImplicitState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ case Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
num of
      Natural
0 -> Maybe Natural
forall a. Maybe a
Nothing
      Natural
n' -> Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
n'
    Maybe Natural
n -> GStateUpdateError
-> Either GStateUpdateError (AddressStateFam 'AddressKindImplicit)
forall a b. a -> Either a b
Left (GStateUpdateError
 -> Either GStateUpdateError (AddressStateFam 'AddressKindImplicit))
-> GStateUpdateError
-> Either GStateUpdateError (AddressStateFam 'AddressKindImplicit)
forall a b. (a -> b) -> a -> b
$ ImplicitAddress
-> TicketKey
-> NamedF Identity Natural "needs"
-> NamedF Identity Natural "has"
-> GStateUpdateError
GStateInsufficientTickets ImplicitAddress
addr TicketKey
key (NamedF Identity Natural "needs"
 -> NamedF Identity Natural "has" -> GStateUpdateError)
-> Param (NamedF Identity Natural "needs")
-> NamedF Identity Natural "has"
-> GStateUpdateError
forall p fn fn'. WithParam p fn fn' => fn -> Param p -> fn'
! Natural -> Param (NamedF Identity Natural "needs")
forall (x :: Symbol) a. IsLabel x a => a
#needs Natural
num (NamedF Identity Natural "has" -> GStateUpdateError)
-> Param (NamedF Identity Natural "has") -> GStateUpdateError
forall p fn fn'. WithParam p fn fn' => fn -> Param p -> fn'
! Natural -> Param (NamedF Identity Natural "has")
forall (x :: Symbol) a. IsLabel x a => a
#has (Natural -> Maybe Natural -> Natural
forall a. a -> Maybe a -> a
fromMaybe Natural
0 Maybe Natural
n)

-- | 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.
addImplicitAddress
  :: ImplicitAddress -> Mutez -> [(TicketKey, Natural)] -> GState -> Either GStateUpdateError GState
addImplicitAddress :: ImplicitAddress
-> Mutez
-> [(TicketKey, Natural)]
-> GState
-> Either GStateUpdateError GState
addImplicitAddress ImplicitAddress
addr Mutez
st [(TicketKey, Natural)]
tickets GState
gs
  | ImplicitAddress
addr ImplicitAddress -> Map ImplicitAddress ImplicitState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` (GState -> Map ImplicitAddress ImplicitState
gsImplicitAddresses GState
gs) = GStateUpdateError -> Either GStateUpdateError GState
forall a b. a -> Either a b
Left (GStateUpdateError -> Either GStateUpdateError GState)
-> GStateUpdateError -> Either GStateUpdateError GState
forall a b. (a -> b) -> a -> b
$ Address -> GStateUpdateError
GStateAddressExists (ImplicitAddress -> Address
forall (kind :: AddressKind). KindedAddress kind -> Address
MkAddress ImplicitAddress
addr)
  | Bool
otherwise = GState -> Either GStateUpdateError GState
forall a b. b -> Either a b
Right (GState -> Either GStateUpdateError GState)
-> GState -> Either GStateUpdateError GState
forall a b. (a -> b) -> a -> b
$
      GState
gs GState -> (GState -> GState) -> GState
forall a b. a -> (a -> b) -> b
& (Map ImplicitAddress ImplicitState
 -> Identity (Map ImplicitAddress ImplicitState))
-> GState -> Identity GState
Lens' GState (Map ImplicitAddress ImplicitState)
gsImplicitAddressesL ((Map ImplicitAddress ImplicitState
  -> Identity (Map ImplicitAddress ImplicitState))
 -> GState -> Identity GState)
-> ((Maybe ImplicitState -> Identity (Maybe ImplicitState))
    -> Map ImplicitAddress ImplicitState
    -> Identity (Map ImplicitAddress ImplicitState))
-> (Maybe ImplicitState -> Identity (Maybe ImplicitState))
-> GState
-> Identity GState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map ImplicitAddress ImplicitState)
-> Lens'
     (Map ImplicitAddress ImplicitState)
     (Maybe (IxValue (Map ImplicitAddress ImplicitState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map ImplicitAddress ImplicitState)
ImplicitAddress
addr ((Maybe ImplicitState -> Identity (Maybe ImplicitState))
 -> GState -> Identity GState)
-> ImplicitState -> GState -> GState
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Mutez
-> HashMap TicketKey Natural -> Maybe KeyHash -> ImplicitState
ImplicitState Mutez
st ([ListElement (HashMap TicketKey Natural)]
-> HashMap TicketKey Natural
forall l. (FromList l, FromListC l) => [ListElement l] -> l
fromList [(TicketKey, Natural)]
[ListElement (HashMap TicketKey Natural)]
tickets) Maybe KeyHash
forall a. Maybe a
Nothing

-- | Add an address if it hasn't been added before.
addContractAddress :: ContractAddress -> ContractState -> GState -> Either GStateUpdateError GState
addContractAddress :: ContractAddress
-> ContractState -> GState -> Either GStateUpdateError GState
addContractAddress ContractAddress
addr ContractState
st GState
gs
  | ContractAddress
addr ContractAddress -> Map ContractAddress ContractState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` (GState -> Map ContractAddress ContractState
gsContractAddresses GState
gs) = GStateUpdateError -> Either GStateUpdateError GState
forall a b. a -> Either a b
Left (GStateUpdateError -> Either GStateUpdateError GState)
-> GStateUpdateError -> Either GStateUpdateError GState
forall a b. (a -> b) -> a -> b
$ Address -> GStateUpdateError
GStateAddressExists (ContractAddress -> Address
forall (kind :: AddressKind). KindedAddress kind -> Address
MkAddress ContractAddress
addr)
  | Bool
otherwise = GState -> Either GStateUpdateError GState
forall a b. b -> Either a b
Right (GState -> Either GStateUpdateError GState)
-> GState -> Either GStateUpdateError GState
forall a b. (a -> b) -> a -> b
$ GState
gs GState -> (GState -> GState) -> GState
forall a b. a -> (a -> b) -> b
& (Map ContractAddress ContractState
 -> Identity (Map ContractAddress ContractState))
-> GState -> Identity GState
Lens' GState (Map ContractAddress ContractState)
gsContractAddressesL ((Map ContractAddress ContractState
  -> Identity (Map ContractAddress ContractState))
 -> GState -> Identity GState)
-> ((Maybe ContractState -> Identity (Maybe ContractState))
    -> Map ContractAddress ContractState
    -> Identity (Map ContractAddress ContractState))
-> (Maybe ContractState -> Identity (Maybe ContractState))
-> GState
-> Identity GState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map ContractAddress ContractState)
-> Lens'
     (Map ContractAddress ContractState)
     (Maybe (IxValue (Map ContractAddress ContractState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map ContractAddress ContractState)
ContractAddress
addr ((Maybe ContractState -> Identity (Maybe ContractState))
 -> GState -> Identity GState)
-> ContractState -> GState -> GState
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ContractState
st

-- | Add an alias for given address, overwriting any existing address for the same alias.
addContractAddressAlias :: ContractAlias -> ContractAddress -> GState -> GState
addContractAddressAlias :: ContractAlias -> ContractAddress -> GState -> GState
addContractAddressAlias ContractAlias
alias ContractAddress
addr = (Bimap ContractAlias ContractAddress
 -> Identity (Bimap ContractAlias ContractAddress))
-> GState -> Identity GState
Lens' GState (Bimap ContractAlias ContractAddress)
gsContractAddressAliasesL ((Bimap ContractAlias ContractAddress
  -> Identity (Bimap ContractAlias ContractAddress))
 -> GState -> Identity GState)
-> ((Maybe ContractAddress -> Identity (Maybe ContractAddress))
    -> Bimap ContractAlias ContractAddress
    -> Identity (Bimap ContractAlias ContractAddress))
-> (Maybe ContractAddress -> Identity (Maybe ContractAddress))
-> GState
-> Identity GState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Bimap ContractAlias ContractAddress)
-> Lens'
     (Bimap ContractAlias ContractAddress)
     (Maybe (IxValue (Bimap ContractAlias ContractAddress)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Bimap ContractAlias ContractAddress)
ContractAlias
alias ((Maybe ContractAddress -> Identity (Maybe ContractAddress))
 -> GState -> Identity GState)
-> ContractAddress -> GState -> GState
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ContractAddress
addr

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

-- | Update balance value associated with given address.
setBalance
  :: forall kind. L1AddressKind kind
  => KindedAddress kind
  -> Mutez
  -> GState
  -> Either GStateUpdateError GState
setBalance :: forall (kind :: AddressKind).
L1AddressKind kind =>
KindedAddress kind
-> Mutez -> GState -> Either GStateUpdateError GState
setBalance KindedAddress kind
addr Mutez
newBalance = KindedAddress kind
-> (AddressStateFam kind
    -> Either GStateUpdateError (AddressStateFam kind))
-> GState
-> Either GStateUpdateError GState
forall (kind :: AddressKind).
KindedAddress kind
-> (AddressStateFam kind
    -> Either GStateUpdateError (AddressStateFam kind))
-> GState
-> Either GStateUpdateError GState
updateAddressState KindedAddress kind
addr ((AddressStateFam kind
  -> Either GStateUpdateError (AddressStateFam kind))
 -> GState -> Either GStateUpdateError GState)
-> (AddressStateFam kind
    -> Either GStateUpdateError (AddressStateFam kind))
-> GState
-> Either GStateUpdateError GState
forall a b. (a -> b) -> a -> b
$
  AddressStateFam kind
-> Either GStateUpdateError (AddressStateFam kind)
forall a b. b -> Either a b
Right (AddressStateFam kind
 -> Either GStateUpdateError (AddressStateFam kind))
-> (AddressStateFam kind -> AddressStateFam kind)
-> AddressStateFam kind
-> Either GStateUpdateError (AddressStateFam kind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter (AddressStateFam kind) (AddressStateFam kind) Mutez Mutez
-> Mutez -> AddressStateFam kind -> AddressStateFam kind
forall s t a b. ASetter s t a b -> b -> s -> t
set (KindedAddress kind -> Lens' (AddressStateFam kind) Mutez
forall (kind :: AddressKind).
L1AddressKind kind =>
KindedAddress kind -> Lens' (AddressStateFam kind) Mutez
balanceLens KindedAddress kind
addr) Mutez
newBalance

lookupBalance :: forall kind. L1AddressKind kind => KindedAddress kind -> GState -> Maybe Mutez
lookupBalance :: forall (kind :: AddressKind).
L1AddressKind kind =>
KindedAddress kind -> GState -> Maybe Mutez
lookupBalance KindedAddress kind
addr = Getting (First Mutez) GState Mutez -> GState -> Maybe Mutez
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Getting (First Mutez) GState Mutez -> GState -> Maybe Mutez)
-> Getting (First Mutez) GState Mutez -> GState -> Maybe Mutez
forall a b. (a -> b) -> a -> b
$ KindedAddress kind
-> Lens' GState (Map (KindedAddress kind) (AddressStateFam kind))
forall (kind :: AddressKind).
KindedAddress kind
-> Lens' GState (Map (KindedAddress kind) (AddressStateFam kind))
addressesL KindedAddress kind
addr ((Map (KindedAddress kind) (AddressStateFam kind)
  -> Const
       (First Mutez) (Map (KindedAddress kind) (AddressStateFam kind)))
 -> GState -> Const (First Mutez) GState)
-> ((Mutez -> Const (First Mutez) Mutez)
    -> Map (KindedAddress kind) (AddressStateFam kind)
    -> Const
         (First Mutez) (Map (KindedAddress kind) (AddressStateFam kind)))
-> Getting (First Mutez) GState Mutez
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map (KindedAddress kind) (AddressStateFam kind))
-> Lens'
     (Map (KindedAddress kind) (AddressStateFam kind))
     (Maybe (IxValue (Map (KindedAddress kind) (AddressStateFam kind))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map (KindedAddress kind) (AddressStateFam kind))
KindedAddress kind
addr ((Maybe (AddressStateFam kind)
  -> Const (First Mutez) (Maybe (AddressStateFam kind)))
 -> Map (KindedAddress kind) (AddressStateFam kind)
 -> Const
      (First Mutez) (Map (KindedAddress kind) (AddressStateFam kind)))
-> ((Mutez -> Const (First Mutez) Mutez)
    -> Maybe (AddressStateFam kind)
    -> Const (First Mutez) (Maybe (AddressStateFam kind)))
-> (Mutez -> Const (First Mutez) Mutez)
-> Map (KindedAddress kind) (AddressStateFam kind)
-> Const
     (First Mutez) (Map (KindedAddress kind) (AddressStateFam kind))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AddressStateFam kind
 -> Const (First Mutez) (AddressStateFam kind))
-> Maybe (AddressStateFam kind)
-> Const (First Mutez) (Maybe (AddressStateFam kind))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((AddressStateFam kind
  -> Const (First Mutez) (AddressStateFam kind))
 -> Maybe (AddressStateFam kind)
 -> Const (First Mutez) (Maybe (AddressStateFam kind)))
-> ((Mutez -> Const (First Mutez) Mutez)
    -> AddressStateFam kind
    -> Const (First Mutez) (AddressStateFam kind))
-> (Mutez -> Const (First Mutez) Mutez)
-> Maybe (AddressStateFam kind)
-> Const (First Mutez) (Maybe (AddressStateFam kind))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KindedAddress kind -> Lens' (AddressStateFam kind) Mutez
forall (kind :: AddressKind).
L1AddressKind kind =>
KindedAddress kind -> Lens' (AddressStateFam kind) Mutez
balanceLens KindedAddress kind
addr

balanceLens
  :: forall kind. L1AddressKind kind
  => KindedAddress kind
  -> Lens' (AddressStateFam kind) Mutez
balanceLens :: forall (kind :: AddressKind).
L1AddressKind kind =>
KindedAddress kind -> Lens' (AddressStateFam kind) Mutez
balanceLens = \case
  ImplicitAddress{} -> (Mutez -> f Mutez) -> ImplicitState -> f ImplicitState
(Mutez -> f Mutez)
-> AddressStateFam kind -> f (AddressStateFam kind)
Lens' ImplicitState Mutez
isBalanceL
  ContractAddress{} -> (Mutez -> f Mutez) -> ContractState -> f ContractState
(Mutez -> f Mutez)
-> AddressStateFam kind -> f (AddressStateFam kind)
Lens' ContractState Mutez
csBalanceL
  where ()
_ = forall (kind :: AddressKind) a. L1AddressKind kind => a -> a
usingImplicitOrContractKind @kind ()

-- | Check if address delegate is set to itself, i.e. it's "registered delegate"
-- in network terms. "Registered delegates" can't change their delegate. On the
-- other hand, those can be set as delegates for other addresses.
isRegisteredDelegate :: ImplicitAddress -> GState -> Bool
isRegisteredDelegate :: ImplicitAddress -> GState -> Bool
isRegisteredDelegate addr :: ImplicitAddress
addr@(ImplicitAddress KeyHash
kh) GState
gs =
  GState
gs GState
-> Getting (First (Maybe KeyHash)) GState (Maybe KeyHash)
-> Maybe (Maybe KeyHash)
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Map ImplicitAddress ImplicitState
 -> Const
      (First (Maybe KeyHash)) (Map ImplicitAddress ImplicitState))
-> GState -> Const (First (Maybe KeyHash)) GState
Lens' GState (Map ImplicitAddress ImplicitState)
gsImplicitAddressesL ((Map ImplicitAddress ImplicitState
  -> Const
       (First (Maybe KeyHash)) (Map ImplicitAddress ImplicitState))
 -> GState -> Const (First (Maybe KeyHash)) GState)
-> ((Maybe KeyHash
     -> Const (First (Maybe KeyHash)) (Maybe KeyHash))
    -> Map ImplicitAddress ImplicitState
    -> Const
         (First (Maybe KeyHash)) (Map ImplicitAddress ImplicitState))
-> Getting (First (Maybe KeyHash)) GState (Maybe KeyHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map ImplicitAddress ImplicitState)
-> Lens'
     (Map ImplicitAddress ImplicitState)
     (Maybe (IxValue (Map ImplicitAddress ImplicitState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map ImplicitAddress ImplicitState)
ImplicitAddress
addr ((Maybe ImplicitState
  -> Const (First (Maybe KeyHash)) (Maybe ImplicitState))
 -> Map ImplicitAddress ImplicitState
 -> Const
      (First (Maybe KeyHash)) (Map ImplicitAddress ImplicitState))
-> ((Maybe KeyHash
     -> Const (First (Maybe KeyHash)) (Maybe KeyHash))
    -> Maybe ImplicitState
    -> Const (First (Maybe KeyHash)) (Maybe ImplicitState))
-> (Maybe KeyHash -> Const (First (Maybe KeyHash)) (Maybe KeyHash))
-> Map ImplicitAddress ImplicitState
-> Const
     (First (Maybe KeyHash)) (Map ImplicitAddress ImplicitState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImplicitState -> Const (First (Maybe KeyHash)) ImplicitState)
-> Maybe ImplicitState
-> Const (First (Maybe KeyHash)) (Maybe ImplicitState)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((ImplicitState -> Const (First (Maybe KeyHash)) ImplicitState)
 -> Maybe ImplicitState
 -> Const (First (Maybe KeyHash)) (Maybe ImplicitState))
-> ((Maybe KeyHash
     -> Const (First (Maybe KeyHash)) (Maybe KeyHash))
    -> ImplicitState -> Const (First (Maybe KeyHash)) ImplicitState)
-> (Maybe KeyHash -> Const (First (Maybe KeyHash)) (Maybe KeyHash))
-> Maybe ImplicitState
-> Const (First (Maybe KeyHash)) (Maybe ImplicitState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe KeyHash -> Const (First (Maybe KeyHash)) (Maybe KeyHash))
-> ImplicitState -> Const (First (Maybe KeyHash)) ImplicitState
Lens' ImplicitState (Maybe KeyHash)
isDelegateL Maybe (Maybe KeyHash) -> Maybe (Maybe KeyHash) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe KeyHash -> Maybe (Maybe KeyHash)
forall a. a -> Maybe a
Just (KeyHash -> Maybe KeyHash
forall a. a -> Maybe a
Just KeyHash
kh)

-- | Set delegate for a given address
setDelegate
  :: forall kind. L1AddressKind kind
  => KindedAddress kind -> Maybe KeyHash -> GState -> Either GStateUpdateError GState
setDelegate :: forall (kind :: AddressKind).
L1AddressKind kind =>
KindedAddress kind
-> Maybe KeyHash -> GState -> Either GStateUpdateError GState
setDelegate KindedAddress kind
addr Maybe KeyHash
newDelegate GState
gs
  | Just oldDelegate :: Maybe KeyHash
oldDelegate@Just{} <- GState
gs GState
-> Getting (First (Maybe KeyHash)) GState (Maybe KeyHash)
-> Maybe (Maybe KeyHash)
forall s a. s -> Getting (First a) s a -> Maybe a
^? KindedAddress kind
-> Lens' GState (Map (KindedAddress kind) (AddressStateFam kind))
forall (kind :: AddressKind).
KindedAddress kind
-> Lens' GState (Map (KindedAddress kind) (AddressStateFam kind))
addressesL KindedAddress kind
addr ((Map (KindedAddress kind) (AddressStateFam kind)
  -> Const
       (First (Maybe KeyHash))
       (Map (KindedAddress kind) (AddressStateFam kind)))
 -> GState -> Const (First (Maybe KeyHash)) GState)
-> ((Maybe KeyHash
     -> Const (First (Maybe KeyHash)) (Maybe KeyHash))
    -> Map (KindedAddress kind) (AddressStateFam kind)
    -> Const
         (First (Maybe KeyHash))
         (Map (KindedAddress kind) (AddressStateFam kind)))
-> Getting (First (Maybe KeyHash)) GState (Maybe KeyHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map (KindedAddress kind) (AddressStateFam kind))
-> Lens'
     (Map (KindedAddress kind) (AddressStateFam kind))
     (Maybe (IxValue (Map (KindedAddress kind) (AddressStateFam kind))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map (KindedAddress kind) (AddressStateFam kind))
KindedAddress kind
addr ((Maybe (AddressStateFam kind)
  -> Const (First (Maybe KeyHash)) (Maybe (AddressStateFam kind)))
 -> Map (KindedAddress kind) (AddressStateFam kind)
 -> Const
      (First (Maybe KeyHash))
      (Map (KindedAddress kind) (AddressStateFam kind)))
-> ((Maybe KeyHash
     -> Const (First (Maybe KeyHash)) (Maybe KeyHash))
    -> Maybe (AddressStateFam kind)
    -> Const (First (Maybe KeyHash)) (Maybe (AddressStateFam kind)))
-> (Maybe KeyHash -> Const (First (Maybe KeyHash)) (Maybe KeyHash))
-> Map (KindedAddress kind) (AddressStateFam kind)
-> Const
     (First (Maybe KeyHash))
     (Map (KindedAddress kind) (AddressStateFam kind))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AddressStateFam kind
 -> Const (First (Maybe KeyHash)) (AddressStateFam kind))
-> Maybe (AddressStateFam kind)
-> Const (First (Maybe KeyHash)) (Maybe (AddressStateFam kind))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((AddressStateFam kind
  -> Const (First (Maybe KeyHash)) (AddressStateFam kind))
 -> Maybe (AddressStateFam kind)
 -> Const (First (Maybe KeyHash)) (Maybe (AddressStateFam kind)))
-> ((Maybe KeyHash
     -> Const (First (Maybe KeyHash)) (Maybe KeyHash))
    -> AddressStateFam kind
    -> Const (First (Maybe KeyHash)) (AddressStateFam kind))
-> (Maybe KeyHash -> Const (First (Maybe KeyHash)) (Maybe KeyHash))
-> Maybe (AddressStateFam kind)
-> Const (First (Maybe KeyHash)) (Maybe (AddressStateFam kind))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe KeyHash -> Const (First (Maybe KeyHash)) (Maybe KeyHash))
-> AddressStateFam kind
-> Const (First (Maybe KeyHash)) (AddressStateFam kind)
Lens' (AddressStateFam kind) (Maybe KeyHash)
delegateLens
  , Maybe KeyHash
oldDelegate Maybe KeyHash -> Maybe KeyHash -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe KeyHash
newDelegate
  -- network fails when new delegate == old delegate == Just kh, so we do likewise
  -- note it _doesn't_ fail when new == old == Nothing
  = GStateUpdateError -> Either GStateUpdateError GState
forall a b. a -> Either a b
Left (GStateUpdateError -> Either GStateUpdateError GState)
-> GStateUpdateError -> Either GStateUpdateError GState
forall a b. (a -> b) -> a -> b
$ L1Address -> Maybe KeyHash -> GStateUpdateError
GStateAlreadySetDelegate (KindedAddress kind -> L1Address
forall {k} (c :: k -> Constraint) (f :: k -> *) (a :: k).
c a =>
f a -> Constrained c f
Constrained KindedAddress kind
addr) Maybe KeyHash
newDelegate
  | ImplicitAddress{} <- KindedAddress kind
addr
  , ImplicitAddress -> GState -> Bool
isRegisteredDelegate KindedAddress kind
ImplicitAddress
addr GState
gs
  -- implicit addresses that are registered delegates can't change delegates
  = GStateUpdateError -> Either GStateUpdateError GState
forall a b. a -> Either a b
Left (GStateUpdateError -> Either GStateUpdateError GState)
-> GStateUpdateError -> Either GStateUpdateError GState
forall a b. (a -> b) -> a -> b
$ ImplicitAddress -> GStateUpdateError
GStateCantDeleteDelegate KindedAddress kind
ImplicitAddress
addr
  | Just h :: KeyHash
h@Hash{ByteString
HashTag 'HashKindPublicKey
hTag :: HashTag 'HashKindPublicKey
hBytes :: ByteString
hTag :: forall (kind :: HashKind). Hash kind -> HashTag kind
hBytes :: forall (kind :: HashKind). Hash kind -> ByteString
..} <- Maybe KeyHash
newDelegate
  , HashKey KeyType
KeyTypeBLS <- HashTag 'HashKindPublicKey
hTag
  = GStateUpdateError -> Either GStateUpdateError GState
forall a b. a -> Either a b
Left (GStateUpdateError -> Either GStateUpdateError GState)
-> GStateUpdateError -> Either GStateUpdateError GState
forall a b. (a -> b) -> a -> b
$ Address -> KeyHash -> GStateUpdateError
GStateNoBLSDelegate (KindedAddress kind -> Address
forall {k} (c :: k -> Constraint) (f :: k -> *) (a :: k).
c a =>
f a -> Constrained c f
Constrained KindedAddress kind
addr) KeyHash
h
  | Just KeyHash
kh <- Maybe KeyHash
newDelegate
  , let keyAddr :: ImplicitAddress
keyAddr = KeyHash -> ImplicitAddress
ImplicitAddress KeyHash
kh
  , Bool -> Bool
forall a. Boolean a => a -> a
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ImplicitAddress -> GState -> Bool
isRegisteredDelegate ImplicitAddress
keyAddr GState
gs
  -- can't set delegate to an address not registered as delegate
  , ImplicitAddress -> Address
forall (kind :: AddressKind). KindedAddress kind -> Address
MkAddress ImplicitAddress
keyAddr Address -> Address -> Bool
forall a. Eq a => a -> a -> Bool
/= KindedAddress kind -> Address
forall (kind :: AddressKind). KindedAddress kind -> Address
MkAddress KindedAddress kind
addr -- but implicit contract can set delegate to itself
  = GStateUpdateError -> Either GStateUpdateError GState
forall a b. a -> Either a b
Left (GStateUpdateError -> Either GStateUpdateError GState)
-> GStateUpdateError -> Either GStateUpdateError GState
forall a b. (a -> b) -> a -> b
$ ImplicitAddress -> GStateUpdateError
GStateNotDelegate ImplicitAddress
keyAddr
  | Bool
otherwise = KindedAddress kind
-> (AddressStateFam kind
    -> Either GStateUpdateError (AddressStateFam kind))
-> GState
-> Either GStateUpdateError GState
forall (kind :: AddressKind).
KindedAddress kind
-> (AddressStateFam kind
    -> Either GStateUpdateError (AddressStateFam kind))
-> GState
-> Either GStateUpdateError GState
updateAddressState KindedAddress kind
addr (AddressStateFam kind
-> Either GStateUpdateError (AddressStateFam kind)
forall a. a -> Either GStateUpdateError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AddressStateFam kind
 -> Either GStateUpdateError (AddressStateFam kind))
-> (AddressStateFam kind -> AddressStateFam kind)
-> AddressStateFam kind
-> Either GStateUpdateError (AddressStateFam kind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe KeyHash -> Identity (Maybe KeyHash))
-> AddressStateFam kind -> Identity (AddressStateFam kind)
Lens' (AddressStateFam kind) (Maybe KeyHash)
delegateLens ((Maybe KeyHash -> Identity (Maybe KeyHash))
 -> AddressStateFam kind -> Identity (AddressStateFam kind))
-> Maybe KeyHash -> AddressStateFam kind -> AddressStateFam kind
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe KeyHash
newDelegate)) GState
gs
  where
    delegateLens :: Lens' (AddressStateFam kind) (Maybe KeyHash)
    delegateLens :: Lens' (AddressStateFam kind) (Maybe KeyHash)
delegateLens = case KindedAddress kind
addr of
      ContractAddress{} -> (Maybe KeyHash -> f (Maybe KeyHash))
-> ContractState -> f ContractState
(Maybe KeyHash -> f (Maybe KeyHash))
-> AddressStateFam kind -> f (AddressStateFam kind)
Lens' ContractState (Maybe KeyHash)
csDelegateL
      ImplicitAddress{} -> (Maybe KeyHash -> f (Maybe KeyHash))
-> ImplicitState -> f ImplicitState
(Maybe KeyHash -> f (Maybe KeyHash))
-> AddressStateFam kind -> f (AddressStateFam kind)
Lens' ImplicitState (Maybe KeyHash)
isDelegateL

type family AddressStateFam kind where
  AddressStateFam 'AddressKindImplicit = ImplicitState
  AddressStateFam 'AddressKindContract = ContractState
  AddressStateFam 'AddressKindSmartRollup = ()

updateAddressState
  :: forall kind. KindedAddress kind
  -> (AddressStateFam kind -> Either GStateUpdateError (AddressStateFam kind))
  -> GState
  -> Either GStateUpdateError GState
updateAddressState :: forall (kind :: AddressKind).
KindedAddress kind
-> (AddressStateFam kind
    -> Either GStateUpdateError (AddressStateFam kind))
-> GState
-> Either GStateUpdateError GState
updateAddressState KindedAddress kind
addr AddressStateFam kind
-> Either GStateUpdateError (AddressStateFam kind)
f GState
gs =
  let addrL :: Lens' GState (Maybe (AddressStateFam kind))
      addrL :: Lens' GState (Maybe (AddressStateFam kind))
addrL = KindedAddress kind
-> Lens' GState (Map (KindedAddress kind) (AddressStateFam kind))
forall (kind :: AddressKind).
KindedAddress kind
-> Lens' GState (Map (KindedAddress kind) (AddressStateFam kind))
addressesL KindedAddress kind
addr ((Map (KindedAddress kind) (AddressStateFam kind)
  -> f (Map (KindedAddress kind) (AddressStateFam kind)))
 -> GState -> f GState)
-> ((Maybe (AddressStateFam kind)
     -> f (Maybe (AddressStateFam kind)))
    -> Map (KindedAddress kind) (AddressStateFam kind)
    -> f (Map (KindedAddress kind) (AddressStateFam kind)))
-> (Maybe (AddressStateFam kind)
    -> f (Maybe (AddressStateFam kind)))
-> GState
-> f GState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map (KindedAddress kind) (AddressStateFam kind))
-> Lens'
     (Map (KindedAddress kind) (AddressStateFam kind))
     (Maybe (IxValue (Map (KindedAddress kind) (AddressStateFam kind))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map (KindedAddress kind) (AddressStateFam kind))
KindedAddress kind
addr
  in case GState
gs GState
-> Getting
     (Maybe (AddressStateFam kind))
     GState
     (Maybe (AddressStateFam kind))
-> Maybe (AddressStateFam kind)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (AddressStateFam kind))
  GState
  (Maybe (AddressStateFam kind))
Lens' GState (Maybe (AddressStateFam kind))
addrL of
    Maybe (AddressStateFam kind)
Nothing -> GStateUpdateError -> Either GStateUpdateError GState
forall a b. a -> Either a b
Left (GStateUpdateError -> Either GStateUpdateError GState)
-> GStateUpdateError -> Either GStateUpdateError GState
forall a b. (a -> b) -> a -> b
$ Address -> GStateUpdateError
GStateUnknownAddress (Address -> GStateUpdateError) -> Address -> GStateUpdateError
forall a b. (a -> b) -> a -> b
$ KindedAddress kind -> Address
forall (kind :: AddressKind). KindedAddress kind -> Address
MkAddress KindedAddress kind
addr
    Just AddressStateFam kind
as -> do
      AddressStateFam kind
newState <- AddressStateFam kind
-> Either GStateUpdateError (AddressStateFam kind)
f AddressStateFam kind
as
      return $ GState
gs GState -> (GState -> GState) -> GState
forall a b. a -> (a -> b) -> b
& (Maybe (AddressStateFam kind)
 -> Identity (Maybe (AddressStateFam kind)))
-> GState -> Identity GState
Lens' GState (Maybe (AddressStateFam kind))
addrL ((Maybe (AddressStateFam kind)
  -> Identity (Maybe (AddressStateFam kind)))
 -> GState -> Identity GState)
-> Maybe (AddressStateFam kind) -> GState -> GState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AddressStateFam kind -> Maybe (AddressStateFam kind)
forall a. a -> Maybe a
Just AddressStateFam kind
newState

addressesL
  :: KindedAddress kind
  -> Lens' GState (Map (KindedAddress kind) (AddressStateFam kind))
addressesL :: forall (kind :: AddressKind).
KindedAddress kind
-> Lens' GState (Map (KindedAddress kind) (AddressStateFam kind))
addressesL = \case
  ImplicitAddress{} -> (Map (KindedAddress kind) (AddressStateFam kind)
 -> f (Map (KindedAddress kind) (AddressStateFam kind)))
-> GState -> f GState
(Map ImplicitAddress ImplicitState
 -> f (Map ImplicitAddress ImplicitState))
-> GState -> f GState
Lens' GState (Map ImplicitAddress ImplicitState)
gsImplicitAddressesL
  ContractAddress{} -> (Map (KindedAddress kind) (AddressStateFam kind)
 -> f (Map (KindedAddress kind) (AddressStateFam kind)))
-> GState -> f GState
(Map ContractAddress ContractState
 -> f (Map ContractAddress ContractState))
-> GState -> f GState
Lens' GState (Map ContractAddress ContractState)
gsContractAddressesL
  SmartRollupAddress{} -> (Map (KindedAddress kind) (AddressStateFam kind)
 -> f (Map (KindedAddress kind) (AddressStateFam kind)))
-> GState -> f GState
(Map SmartRollupAddress () -> f (Map SmartRollupAddress ()))
-> GState -> f GState
Lens' GState (Map SmartRollupAddress ())
gsSmartRollupAddressesL

-- | 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
. ((ContractAddress, ContractState)
 -> Maybe (ContractHash, SomeParamType))
-> [(ContractAddress, ContractState)]
-> [(ContractHash, SomeParamType)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ContractAddress, ContractState)
-> Maybe (ContractHash, SomeParamType)
extractContract ([(ContractAddress, ContractState)]
 -> [(ContractHash, SomeParamType)])
-> (GState -> [(ContractAddress, ContractState)])
-> GState
-> [(ContractHash, SomeParamType)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ContractAddress ContractState
-> [(Key (Map ContractAddress ContractState),
     Val (Map ContractAddress ContractState))]
Map ContractAddress ContractState
-> [(ContractAddress, ContractState)]
forall t. ToPairs t => t -> [(Key t, Val t)]
toPairs (Map ContractAddress ContractState
 -> [(ContractAddress, ContractState)])
-> (GState -> Map ContractAddress ContractState)
-> GState
-> [(ContractAddress, ContractState)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GState -> Map ContractAddress ContractState
gsContractAddresses
 where
    extractContract
      :: (ContractAddress, ContractState) -> Maybe (ContractHash, SomeParamType)
    extractContract :: (ContractAddress, ContractState)
-> Maybe (ContractHash, SomeParamType)
extractContract =
      \case (ContractAddress ContractHash
ca, ContractState{Maybe KeyHash
Mutez
Contract cp st
Value st
csBalance :: ContractState -> Mutez
csContract :: ()
csStorage :: ()
csDelegate :: ContractState -> Maybe KeyHash
csBalance :: Mutez
csContract :: Contract cp st
csStorage :: Value st
csDelegate :: Maybe KeyHash
..}) ->
              (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)