module Michelson.Runtime.GState
(
ContractState (..)
, getTypedContract
, getTypedStorage
, 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 Fmt ((+|), (|+), (||+))
import Formatting.Buildable (Buildable(build))
import System.IO.Error (IOError, isDoesNotExistError)
import Michelson.TypeCheck
(SomeContract(..), StorageOrParameter(..), TCError, TcOriginatedContracts, typeCheckContract,
typeCheckStorageOrParameter)
import Michelson.Typed (SomeValue)
import Michelson.Untyped (Contract, Type, Value, para)
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 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 (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 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{..} =
typeCheckStorageOrParameter Storage csStorage (extractAllContracts gs) csContract
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 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 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 (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"