-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
module Main
( main
) where
import Control.Exception.Safe (throwString)
import Data.Aeson qualified as Aeson
import Data.Default (def)
import Data.Singletons (demote, fromSing)
import Data.Type.Equality (pattern Refl)
import Fmt (blockListF, build, nameF, pretty, (+|), (|+))
import GHC.IO.Encoding (setFileSystemEncoding)
import Options.Applicative qualified as Opt
import System.IO (utf8)
import Morley.Client
import Morley.Client.Parser
import Morley.Client.RPC
import Morley.Client.Util (extractAddressesFromValue)
import Morley.Micheline (fromExpression, toExpression, unStringEncode)
import Morley.Michelson.Runtime (prepareContract)
import Morley.Michelson.TypeCheck qualified as TC
import Morley.Michelson.Typed (Contract, Contract'(..), SomeContract(..))
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.Value (Value'(..))
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Core (prettyTez)
import Morley.Util.Constrained
import Morley.Util.Exception (throwLeft)
import Morley.Util.Main (wrapMain)
mainImpl :: ClientArgsRaw -> MorleyClientM ()
mainImpl cmd =
case cmd of
Originate OriginateArgs{..} -> do
contract <- liftIO $ prepareContract oaMbContractFile
let originator = oaOriginateFrom
originatorAA <- resolveAddressWithAlias originator
(operationHash, contractAddr) <-
originateUntypedContract OverwriteDuplicateAlias oaContractName originatorAA oaInitialBalance
contract oaInitialStorage oaMbFee oaDelegate
putTextLn "Contract was successfully deployed."
putTextLn $ "Operation hash: " <> pretty operationHash
putTextLn $ "Contract address: " <> formatAddress contractAddr
Transfer TransferArgs{..} -> do
sendAddress <- resolveAddressWithAlias taSender
destAddress <- resolveAddress taDestination
(operationHash, contractEvents) :: (OperationHash, [IntOpEvent]) <-
withConstrained destAddress \case
destContract@ContractAddress{} -> do
contract <- getContract destContract
SomeContract (Contract{} :: Contract cp st) <-
throwLeft $ pure $ TC.typeCheckingWith def $ TC.typeCheckContract contract
let addrs = extractAddressesFromValue taParameter & mapMaybe \case
MkAddress x@ContractAddress{} -> Just x
_ -> Nothing
tcOriginatedContracts <- getContractsParameterTypes addrs
parameter <- throwLeft $ pure $ TC.typeCheckingWith def $
TC.typeVerifyParameter @cp tcOriginatedContracts taParameter
transfer sendAddress destContract taAmount U.DefEpName parameter taMbFee
destImplicit@ImplicitAddress {} -> case taParameter of
U.ValueUnit -> transfer sendAddress destImplicit taAmount U.DefEpName VUnit Nothing
_ -> throwString ("The transaction parameter must be 'Unit' "
<> "when transferring to an implicit account")
putTextLn $ "Transaction was successfully sent.\nOperation hash " <> pretty operationHash <> "."
unless (null contractEvents) do
putTextLn $ "Additionally, the following contract events were emitted:"
putTextLn $ pretty $ blockListF contractEvents
TransferTicket TransferTicketArgs{..} -> T.withUType ttaTicketType \(_ :: T.Notes t) -> do
T.Dict <- throwLeft $ pure $ first (TC.UnsupportedTypeForScope (demote @t))
$ T.checkScope @(T.ParameterScope t, T.Comparable t)
sendAddress <- resolveAddressWithAlias ttaSender
destAddress <- resolveAddress ttaDestination
ticketer <- resolveAddress ttaTicketTicketer
(operationHash, contractEvents) :: (OperationHash, [IntOpEvent]) <-
withConstrained destAddress \case
destContract@ContractAddress{} -> do
contract <- getContract destContract
SomeContract (Contract{} :: Contract cp st) <-
throwLeft $ pure $ TC.typeCheckingWith def $ TC.typeCheckContract contract
Constrained (_ :: T.SingT t') :: Constrained T.SingI T.SingT <- case T.sing @cp of
T.STTicket x -> pure $ Constrained @T.SingI x
x -> throwM $ TC.TcContractError @U.ExpandedOp
("Expected contract to accept tickets, but it had type " <> pretty (fromSing x))
$ Just $ TC.UnexpectedType (one $ one $ "ticket 'a")
Refl <- T.requireEq @t @t' $ throwM . TC.TypeEqError
parameter <- throwLeft $ pure $ TC.typeCheckingWith def $ do
TC.typeCheckValue @t' ttaTicketContents
transferTicket @_ @t' sendAddress destContract ticketer parameter ttaTicketAmount
U.DefEpName ttaMbFee
destImplicit@ImplicitAddress{} -> do
parameter <- throwLeft $ pure $ TC.typeCheckingWith def $
TC.typeCheckValue @t ttaTicketContents
transferTicket sendAddress destImplicit ticketer parameter ttaTicketAmount
U.DefEpName ttaMbFee
putTextLn $ "Tickets successfully sent.\nOperation hash " <> pretty operationHash <> "."
unless (null contractEvents) do
putTextLn $ "Additionally, the following contract events were emitted:"
putTextLn $ pretty $ blockListF contractEvents
GetBalance addrOrAlias -> do
balance <- getBalance =<< resolveAddress addrOrAlias
putTextLn $ prettyTez balance
GetBlockHeader blockId -> do
blockHeader <- getBlockHeader blockId
putStrLn $ Aeson.encode blockHeader
GetScriptSize GetScriptSizeArgs{..} -> do
contract <- liftIO $ prepareContract (Just ssScriptFile)
void . throwLeft . pure . TC.typeCheckingWith def $
TC.typeCheckContractAndStorage contract ssStorage
size <- computeUntypedContractSize contract ssStorage
print size
GetBlockOperations blockId -> do
operationLists <- getBlockOperations blockId
forM_ operationLists $ \operations -> do
forM_ operations $ \BlockOperation {..} -> do
putTextLn $ "Hash: " <> boHash
putTextLn $ "Contents: "
forM_ (orwmResponse <$> boContents) \case
TransactionOpResp to -> putStrLn $ Aeson.encode to
OtherOpResp -> putTextLn "Non-transaction operation"
putTextLn ""
putTextLn "——————————————————————————————————————————————————\n"
TicketBalance owner' TicketBalanceArgs{..} -> do
owner <- resolveAddress owner'
bal <- getTicketBalance owner GetTicketBalance
{ gtbContent = toExpression tbaContent
, gtbContentType = toExpression tbaContentType
, gtbTicketer = tbaTicketer
}
print bal
AllTicketBalances owner' -> do
owner <- resolveAddress owner'
bals <- getAllTicketBalances owner
forM_ bals \GetAllTicketBalancesResponse{..} -> do
content <- either throwM pure $ fromExpression @U.Value gatbrContent
ty <- either throwM pure $ fromExpression @U.Ty gatbrContentType
putTextLn $ pretty @Text $
nameF "Ticketer" (build gatbrTicketer) |+ ", "
+| nameF "content" (build content) |+ ", "
+| nameF "type" (build ty) |+ ", "
+| nameF "amount" (build $ unStringEncode gatbrAmount)
main :: IO ()
main = wrapMain $ do
-- grepcake: the following line is needed to parse CL arguments (argv) in
-- utf-8. It might be necessary to add the similar line to other
-- executables. However, I've filed the issue for `with-utf8`
-- (https://github.com/serokell/haskell-with-utf8/issues/8). If it gets fixed
-- in upstream, this line should be safe to remove. In that case, FIXME.
setFileSystemEncoding utf8
disableAlphanetWarning
ClientArgs parsedConfig cmd <- Opt.execParser morleyClientInfo
env <- mkMorleyClientEnv parsedConfig
runMorleyClientM env (mainImpl cmd)