module Michelson.Runtime.GState
(
ContractState (..)
, getTypedContract
, getTypedStorage
, SomeContractAndStorage (..)
, getTypedContractAndStorage
, AddressState (..)
, asBalance
, GState (..)
, gsChainIdL
, gsAddressesL
, genesisAddresses
, genesisKeyHashes
, genesisAddress
, genesisAddress1
, genesisAddress2
, genesisAddress3
, genesisAddress4
, genesisAddress5
, genesisAddress6
, genesisKeyHash
, initGState
, readGState
, writeGState
, GStateUpdate (..)
, GStateUpdateError (..)
, applyUpdate
, applyUpdates
, extractAllContracts
) where
import Control.Lens (at, makeLensesWith)
import Data.Aeson (FromJSON(..), ToJSON(..), object, withObject, (.:), (.=))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
import Data.Aeson.Options (defaultOptions)
import Data.Aeson.TH (deriveJSON)
import qualified Data.ByteString.Lazy as LBS
import Data.List.NonEmpty ((!!))
import qualified Data.Map.Strict as Map
import Data.Typeable ((:~:)(..), eqT)
import Fmt ((+|), (|+), (||+))
import Formatting.Buildable (Buildable(build))
import System.IO.Error (IOError, isDoesNotExistError)
import Michelson.TypeCheck
(SomeContract(..), TCError, TcOriginatedContracts, typeCheckContract, typeCheckTopLevelType)
import Michelson.Typed (SomeValue, SomeValue'(..))
import qualified Michelson.Typed as T
import Michelson.Typed.Scope
import Michelson.Untyped (Contract, Type, Value, para, stor)
import Tezos.Address (Address(..), ContractHash)
import Tezos.Core (ChainId, Mutez, divModMutezInt, dummyChainId)
import Tezos.Crypto
import Util.Lens
data ContractState = ContractState
{ csBalance :: Mutez
, csStorage :: Value
, csContract :: Contract
, csTypedContract :: (Maybe SomeContract)
, csTypedStorage :: (Maybe SomeValue)
}
deriving stock instance Show ContractState
instance ToJSON ContractState where
toJSON ContractState{..} = object
[ "csBalance" .= csBalance
, "csStorage" .= csStorage
, "csContract" .= csContract
]
instance FromJSON ContractState where
parseJSON = withObject "contractstate" $ \o -> do
csBalance <- o .: "csBalance"
csStorage <- o .: "csStorage"
csContract <- o .: "csContract"
let csTypedContract = Nothing
let csTypedStorage = Nothing
return ContractState {..}
instance Buildable ContractState where
build ContractState{..} =
"Contractstate:\n csBalance: " +| csBalance |+
"\n csStorage: " +| csStorage |+
"\n csContract: " +| csContract |+
"\n csTypedContract: " +| csTypedContract ||+
"\n csTypedStorage: " +| csTypedStorage ||+ ""
data AddressState
= ASSimple Mutez
| ASContract ContractState
deriving stock (Show, Generic)
instance Buildable AddressState where
build =
\case
ASSimple balance -> "Balance = " +| balance |+ ""
ASContract cs -> build cs
deriveJSON defaultOptions ''AddressState
asBalance :: AddressState -> Mutez
asBalance =
\case
ASSimple b -> b
ASContract cs -> csBalance cs
data GState = GState
{ gsChainId :: ChainId
, gsAddresses :: Map Address AddressState
} deriving stock (Show)
makeLensesWith postfixLFields ''GState
deriveJSON defaultOptions ''GState
getTypedContract :: GState -> ContractState -> Either TCError SomeContract
getTypedContract gs ContractState{..} =
typeCheckContract (extractAllContracts gs) csContract
getTypedStorage :: GState -> ContractState -> Either TCError SomeValue
getTypedStorage gs ContractState{..} =
typeCheckTopLevelType (extractAllContracts gs) (stor csContract) csStorage
data SomeContractAndStorage =
forall cp st. (ParameterScope cp, StorageScope st) => SomeContractAndStorage
{ scsContract :: T.FullContract cp st
, scsStorage :: T.Value st
}
getTypedContractAndStorage
:: (TCError -> err)
-> (TCError -> err)
-> GState
-> ContractState
-> Either err SomeContractAndStorage
getTypedContractAndStorage liftContractErr liftStorageErr gs cs = do
SomeContract (contract@T.FullContract{} :: T.FullContract cp st) <-
first liftContractErr $ getTypedContract gs cs
SomeValue (storage :: T.Value st') <-
first liftStorageErr $ getTypedStorage gs cs
Refl <- pure $ eqT @st @st'
?: error "Storage type does not match the contract in runtime state"
return $ SomeContractAndStorage contract storage
genesisAddressesNum :: Word
genesisAddressesNum = 10
genesisSecrets :: NonEmpty SecretKey
genesisSecrets = do
i <- 1 :| [2 .. genesisAddressesNum]
let seed = encodeUtf8 (show i :: Text)
return $ detSecretKey seed
genesisKeyHashes :: NonEmpty KeyHash
genesisKeyHashes = hashKey . toPublic <$> genesisSecrets
genesisAddresses :: NonEmpty Address
genesisAddresses = KeyAddress <$> genesisKeyHashes
genesisKeyHash :: KeyHash
genesisKeyHash = head genesisKeyHashes
genesisAddress :: Address
genesisAddress = head genesisAddresses
genesisAddress1, genesisAddress2, genesisAddress3 :: Address
genesisAddress4, genesisAddress5, genesisAddress6 :: Address
genesisAddress1 = genesisAddresses !! 1
genesisAddress2 = genesisAddresses !! 2
genesisAddress3 = genesisAddresses !! 3
genesisAddress4 = genesisAddresses !! 4
genesisAddress5 = genesisAddresses !! 5
genesisAddress6 = genesisAddresses !! 6
initGState :: GState
initGState =
GState
{ gsChainId = dummyChainId
, gsAddresses = Map.fromList
[ (genesis, ASSimple money)
| let (money, _) = maxBound @Mutez `divModMutezInt` genesisAddressesNum
?: error "Number of genesis addresses is 0"
, genesis <- toList genesisAddresses
]
}
data GStateParseError =
GStateParseError String
deriving stock (Show)
instance Exception GStateParseError where
displayException (GStateParseError str) = "Failed to parse GState: " <> str
readGState :: FilePath -> IO GState
readGState fp = (LBS.readFile fp >>= parseFile) `catch` onExc
where
parseFile :: LByteString -> IO GState
parseFile lByteString =
if null lByteString
then pure initGState
else (either (throwM . GStateParseError) pure . Aeson.eitherDecode') lByteString
onExc :: IOError -> IO GState
onExc exc
| isDoesNotExistError exc = pure initGState
| otherwise = throwM exc
writeGState :: FilePath -> GState -> IO ()
writeGState fp gs = LBS.writeFile fp (Aeson.encodePretty' config gs)
where
config =
Aeson.defConfig
{ Aeson.confTrailingNewline = True
}
data GStateUpdate
= GSAddAddress Address AddressState
| GSSetStorageValue Address Value SomeValue
| GSSetBalance Address Mutez
deriving stock (Show)
instance Buildable GStateUpdate where
build =
\case
GSAddAddress addr st ->
"Add address " +| addr |+ " with state " +| st |+ ""
GSSetStorageValue addr val _ ->
"Set storage value of address " +| addr |+ " to " +| val |+ ""
GSSetBalance addr balance ->
"Set balance of address " +| addr |+ " to " +| balance |+ ""
data GStateUpdateError
= GStateAddressExists Address
| GStateUnknownAddress Address
| GStateNotContract Address
deriving stock (Show)
instance Buildable GStateUpdateError where
build =
\case
GStateAddressExists addr -> "Address already exists: " <> build addr
GStateUnknownAddress addr -> "Unknown address: " <> build addr
GStateNotContract addr -> "Address doesn't have contract: " <> build addr
applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState
applyUpdate =
\case
GSAddAddress addr st ->
maybeToRight (GStateAddressExists addr) . addAddress addr st
GSSetStorageValue addr newValue newTypedValue ->
setStorageValue addr newValue newTypedValue
GSSetBalance addr newBalance -> setBalance addr newBalance
applyUpdates :: [GStateUpdate] -> GState -> Either GStateUpdateError GState
applyUpdates = flip (foldM (flip applyUpdate))
addAddress :: Address -> AddressState -> GState -> Maybe GState
addAddress addr st gs
| addr `Map.member` accounts = Nothing
| otherwise = Just (gs {gsAddresses = accounts & at addr .~ Just st})
where
accounts = gsAddresses gs
setStorageValue ::
Address -> Value -> SomeValue -> GState -> Either GStateUpdateError GState
setStorageValue addr newValue newTypedValue = updateAddressState addr modifier
where
modifier (ASSimple _) = Left (GStateNotContract addr)
modifier (ASContract cs) = Right $ ASContract $
cs { csStorage = newValue
, csTypedStorage = Just newTypedValue
}
setBalance :: Address -> Mutez -> GState -> Either GStateUpdateError GState
setBalance addr newBalance = updateAddressState addr (Right . modifier)
where
modifier (ASSimple _) = ASSimple newBalance
modifier (ASContract cs) = ASContract (cs {csBalance = newBalance})
updateAddressState ::
Address
-> (AddressState -> Either GStateUpdateError AddressState)
-> GState
-> Either GStateUpdateError GState
updateAddressState addr f gs =
case addresses ^. at addr of
Nothing -> Left (GStateUnknownAddress addr)
Just as -> do
newState <- f as
return $ gs { gsAddresses = addresses & at addr .~ Just newState }
where
addresses = gsAddresses gs
extractAllContracts :: GState -> TcOriginatedContracts
extractAllContracts = Map.fromList . mapMaybe extractContract . toPairs . gsAddresses
where
extractContract :: (Address, AddressState) -> Maybe (ContractHash, Type)
extractContract =
\case (KeyAddress _, ASSimple {}) -> Nothing
(KeyAddress _, _) -> error "broken GState"
(ContractAddress ca, ASContract cs) -> Just (ca, para $ csContract cs)
(ContractAddress _, _) -> error "broken GState"