module Morley.Runtime.GState
(
ContractState (..)
, AddressState (..)
, asBalance
, GState (..)
, genesisAddress
, genesisAddressText
, genesisKeyHash
, initGState
, readGState
, writeGState
, GStateUpdate (..)
, GStateUpdateError (..)
, applyUpdate
, applyUpdates
) 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 qualified Data.Map.Strict as Map
import Fmt (genericF, pretty, (+|), (|+))
import Formatting.Buildable (Buildable(build))
import System.IO.Error (IOError, isDoesNotExistError)
import Michelson.Untyped (UntypedContract, UntypedValue)
import Morley.Types ()
import Tezos.Address (Address(..))
import Tezos.Core (Mutez)
import Tezos.Crypto (KeyHash, parseKeyHash)
data ContractState = ContractState
{ csBalance :: !Mutez
, csStorage :: !UntypedValue
, csContract :: !UntypedContract
} 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
genesisAddressText :: Text
genesisAddressText = "tz1Yz3VPaCNB5FjhdEVnSoN8Xv3ZM8g2LYhw"
genesisKeyHash :: KeyHash
genesisKeyHash =
either (error . mappend "genesisKeyHash: " . pretty) id $
parseKeyHash genesisAddressText
genesisAddress :: Address
genesisAddress = KeyAddress genesisKeyHash
initGState :: GState
initGState =
GState
{ gsAddresses = Map.fromList
[ (genesisAddress, ASSimple maxBound)
]
}
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 length lByteString == 0
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
!UntypedValue
| 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 -> UntypedValue -> 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