module Michelson.Runtime.GState
(
ContractState (..)
, AddressState (..)
, asBalance
, GState (..)
, genesisAddresses
, genesisKeyHashes
, genesisAddress
, genesisAddress1
, genesisAddress2
, genesisAddress3
, genesisAddress4
, genesisAddress5
, genesisAddress6
, genesisKeyHash
, initGState
, readGState
, writeGState
, GStateUpdate (..)
, GStateUpdateError (..)
, applyUpdate
, applyUpdates
, extractAllContracts
) where
import Control.Lens (at)
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 (genericF, (+|), (|+))
import Formatting.Buildable (Buildable(build))
import System.IO.Error (IOError, isDoesNotExistError)
import Michelson.TypeCheck (TcOriginatedContracts)
import Michelson.Untyped (Contract, Type, Value, para)
import Tezos.Address (Address(..))
import Tezos.Core (Mutez, divModMutezInt)
import Tezos.Crypto
data ContractState = ContractState
{ csBalance :: !Mutez
, csStorage :: !Value
, csContract :: !Contract
} deriving (Show, Generic, Eq)
instance Buildable ContractState where
build = genericF
deriveJSON defaultOptions ''ContractState
data AddressState
= ASSimple !Mutez
| ASContract !ContractState
deriving (Show, Generic, Eq)
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
{ gsAddresses :: Map Address AddressState
} deriving Show
deriveJSON defaultOptions ''GState
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
{ gsAddresses = Map.fromList
[ (genesis, ASSimple money)
| genesis <- toList genesisAddresses
, let (money, _) = maxBound @Mutez `divModMutezInt` genesisAddressesNum
?: error "Number of genesis addresses is 0"
]
}
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
| GSSetBalance !Address
!Mutez
deriving (Show, Eq)
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 -> setStorageValue addr newValue
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 -> GState -> Either GStateUpdateError GState
setStorageValue addr newValue = updateAddressState addr modifier
where
modifier (ASSimple _) = Left (GStateNotContract addr)
modifier (ASContract cs) = Right $ ASContract $ cs { csStorage = newValue }
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.mapMaybe extractContract . gsAddresses
where
extractContract :: AddressState -> Maybe Type
extractContract =
\case ASSimple {} -> Nothing
ASContract cs -> Just (para $ csContract cs)