From 5e345ceb2f69f9fbf65214bf0bd886917cef6c85 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Mon, 15 May 2023 15:08:16 -0400 Subject: [PATCH] Add load command to cli --- .../Language/Marlowe/Runtime/CLI/Command.hs | 7 + .../Marlowe/Runtime/CLI/Command/Load.hs | 336 ++++++++++++++++++ .../app/Language/Marlowe/Runtime/CLI/Monad.hs | 2 + marlowe-runtime-cli/app/Main.hs | 6 +- marlowe-runtime-cli/marlowe-runtime-cli.cabal | 17 +- 5 files changed, 359 insertions(+), 9 deletions(-) create mode 100644 marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Command/Load.hs diff --git a/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Command.hs b/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Command.hs index 6a18ceb263..dfb633f44d 100644 --- a/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Command.hs +++ b/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Command.hs @@ -18,6 +18,7 @@ import Language.Marlowe.Runtime.CLI.Command.Apply , runApplyCommand ) import Language.Marlowe.Runtime.CLI.Command.Create (CreateCommand, createCommandParser, runCreateCommand) +import Language.Marlowe.Runtime.CLI.Command.Load import Language.Marlowe.Runtime.CLI.Command.Log (LogCommand, logCommandParser, runLogCommand) import Language.Marlowe.Runtime.CLI.Command.Submit (SubmitCommand, runSubmitCommand, submitCommandParser) import Language.Marlowe.Runtime.CLI.Command.Tx (TxCommand) @@ -42,6 +43,7 @@ data Command = Apply (TxCommand ApplyCommand) | Create (TxCommand CreateCommand) | Log LogCommand + | Load LoadCommand | Submit SubmitCommand | Withdraw (TxCommand WithdrawCommand) @@ -66,6 +68,10 @@ getOptions = do , command "create" $ Create <$> createCommandParser , command "withdraw" $ Withdraw <$> withdrawCommandParser ] + , hsubparser $ mconcat + [ commandGroup "Contract store commands" + , command "load" $ Load <$> loadCommandParser + ] , hsubparser $ mconcat [ commandGroup "Low level commands" , command "submit" $ Submit <$> submitCommandParser @@ -89,6 +95,7 @@ runCommand = \case Log cmd -> runLogCommand cmd Submit cmd -> runSubmitCommand cmd Withdraw cmd -> runWithdrawCommand cmd + Load cmd -> runLoadCommand cmd -- | Interpret a CLI action in IO using the provided options. runCLIWithOptions :: STM () -> Options -> CLI a -> IO a diff --git a/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Command/Load.hs b/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Command/Load.hs new file mode 100644 index 0000000000..0cbb71579a --- /dev/null +++ b/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Command/Load.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ViewPatterns #-} + +module Language.Marlowe.Runtime.CLI.Command.Load + ( LoadCommand(..) + , loadCommandParser + , runLoadCommand + ) where + +import Control.Monad (foldM, unless) +import qualified Control.Monad as Monad +import Control.Monad.Except (ExceptT(ExceptT), runExceptT, throwError, withExceptT) +import Control.Monad.Reader (MonadReader(ask), ReaderT, local, runReaderT) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Control (control) +import Control.Monad.Trans.Reader (mapReaderT) +import Data.Aeson hiding (Value) +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types hiding (Value) +import Data.List (sortOn) +import qualified Data.Text as T +import Data.Yaml (ParseException, decodeFileEither, prettyPrintParseException) +import Language.Marlowe.Core.V1.Semantics.Types (AccountId, Action, Observation, Payee, Timeout, Token, Value, ValueId) +import Language.Marlowe.Protocol.Load.Client + (ClientStCanPush(..), ClientStComplete(..), ClientStPop, ClientStProcessing(..), MarloweLoadClient(MarloweLoadClient)) +import Language.Marlowe.Protocol.Load.Types (Node(..)) +import Language.Marlowe.Runtime.CLI.Monad (CLI) +import Language.Marlowe.Runtime.ChainSync.Api (DatumHash) +import Language.Marlowe.Runtime.Client (runMarloweLoadClient) +import Network.TypedProtocol (N(..), Nat(..)) +import Options.Applicative (ParserInfo, help, info, metavar, progDesc, strArgument) +import Plutus.V2.Ledger.Api (POSIXTime(..)) +import System.Exit (exitFailure) +import System.FilePath (takeDirectory) +import System.IO (hFlush, hPutStrLn, stderr) +import Text.Printf (hPrintf) +import UnliftIO (atomicModifyIORef, liftIO, newIORef) +import UnliftIO.Directory (doesFileExist, getCurrentDirectory, makeAbsolute, setCurrentDirectory, withCurrentDirectory) + +newtype LoadCommand = LoadCommand + { contractFile :: FilePath + } + +loadCommandParser :: ParserInfo LoadCommand +loadCommandParser = info parser $ progDesc "Load a contract into the runtime" + where + parser = LoadCommand + <$> contractFileOption + contractFileOption = strArgument $ mconcat + [ metavar "FILE_PATH" + , help "A file that contains the JSON representation of the contract to load." + ] + +runLoadCommand :: LoadCommand -> CLI () +runLoadCommand LoadCommand{..} = do + result <- runExceptT $ flip runReaderT [] do + nodeCount <- countNodes 0 contractFile + progress <- newIORef (-1 :: Int) + let + countWidth = floor (logBase 10 $ realToFrac nodeCount :: Double) + 1 :: Int + printStr = " [%-32s] %" <> show countWidth <> "d of " <> show nodeCount <> " nodes transferred.\r" + incrementProgress = do + newProgress <- atomicModifyIORef progress \i -> (i + 1, i + 1) + let + bar + | newProgress == 0 = "" + | newProgress == nodeCount = replicate 32 '=' + | otherwise = reverse $ '>' : replicate ((newProgress * 32 `div` nodeCount) - 1) '=' + liftIO $ hPrintf stderr printStr bar newProgress + liftIO $ hFlush stderr + fmap (nodeCount,) + $ lift + $ ExceptT + $ withCurrentDirectory "." + $ runMarloweLoadClient + $ loadClient incrementProgress contractFile + liftIO case result of + Left err -> do + case err of + FileNotFound [] path -> do + hPrintf stderr "Cannot find contract file %s" path + FileNotFound (referencingFile : _) path -> do + hPrintf stderr "Cannot find contract file %s imported by %s" path referencingFile + FileInvalid referencingFile decodeError -> do + hPrintf stderr "Error in file %s:\n%s" referencingFile $ prettyPrintParseException decodeError + CyclicImport path -> do + hPrintf stderr "Cyclic import detected of file %s" path + hPutStrLn stderr "" + exitFailure + Right (nodeCount, hash) -> do + let width = nodeCount * 2 + length @[] " [] of nodes transferred." + 32 + hPrintf stderr ("%-" <> show width <> "s\n") ("Done." :: String) + putStrLn $ read $ show hash + +type CountM = ReaderT [FilePath] (ExceptT LoadError CLI) + +countNodes :: Int -> FilePath -> CountM Int +countNodes count path = withContract path $ countNodes' count + +countNodes' :: Int -> LoadContract -> CountM Int +countNodes' count = \case + Close -> pure $ count + 1 + Pay _ _ _ _ c -> countNodes' (count + 1) c + If _ l r -> do + countL <- countNodes' (count + 1) l + countNodes' countL r + When cases _ c -> do + count' <- foldM countCase (count + 1) cases + countNodes' count' c + Let _ _ c -> countNodes' (count + 1) c + Assert _ c -> countNodes' (count + 1) c + Import path -> countNodes count path + +countCase :: Int -> LoadCase -> CountM Int +countCase count (LoadCase _ c) = countNodes' (count + 1) c + + +withContract :: FilePath -> (LoadContract -> CountM a) -> CountM a +withContract path m = do + fileExists <- doesFileExist path + breadcrumb <- ask + unless fileExists $ throwError $ FileNotFound breadcrumb path + absPath <- makeAbsolute path + Monad.when (absPath `elem` breadcrumb) $ throwError $ CyclicImport absPath + control \runInBase -> withCurrentDirectory (takeDirectory path) $ runInBase do + contract <- mapReaderT (withExceptT (FileInvalid absPath)) + $ lift + $ ExceptT + $ liftIO + $ decodeFileEither absPath + local (absPath :) $ m contract + +data LoadError + = FileNotFound [FilePath] FilePath + | FileInvalid FilePath ParseException + | CyclicImport FilePath + +loadClient + :: CLI () + -> FilePath + -> MarloweLoadClient CLI (Either LoadError DatumHash) +loadClient incrementProgress rootFile = + MarloweLoadClient do + incrementProgress + startDir <- getCurrentDirectory + pure $ processing [startDir] (Import rootFile) StateRoot + where + processing + :: [FilePath] + -> LoadContract + -> ClientState node + -> ClientStProcessing node CLI (Either LoadError DatumHash) + processing breadcrumb contract state = ClientStProcessing \n -> + push breadcrumb contract state n + + push + :: [FilePath] + -> LoadContract + -> ClientState node + -> Nat n + -> CLI (ClientStCanPush n node CLI (Either LoadError DatumHash)) + push breadcrumb contract state Zero = do + pure + $ RequestResume + $ processing breadcrumb contract state + push breadcrumb contract state (Succ n) = case contract of + Close -> do + incrementProgress + pure $ PushClose $ pop breadcrumb state n + Pay payee payor token value next -> do + incrementProgress + pure $ PushPay payee payor token value $ push breadcrumb next (StatePay state) n + If obs tru fal -> do + incrementProgress + pure $ PushIf obs $ push breadcrumb tru (StateIfL fal state) n + When cases timeout fallback -> do + incrementProgress + pure $ PushWhen timeout case cases of + [] -> push breadcrumb fallback (StateWhen state) n + (c : cs) -> pushCase breadcrumb n c cs fallback state + Let valueId value next -> do + incrementProgress + pure $ PushLet valueId value $ push breadcrumb next (StateLet state) n + Assert obs next -> do + incrementProgress + pure $ PushAssert obs $ push breadcrumb next (StateAssert state) n + Import path -> do + result <- runExceptT do + fileExists <- doesFileExist path + unless fileExists $ throwError $ FileNotFound breadcrumb path + absPath <- makeAbsolute path + Monad.when (absPath `elem` breadcrumb) $ throwError $ CyclicImport absPath + setCurrentDirectory $ takeDirectory path + fmap (absPath,) $ withExceptT (FileInvalid absPath) $ ExceptT $ liftIO $ decodeFileEither absPath + case result of + Left err -> pure $ Abort $ Left err + Right (absPath, contract') -> push (absPath : breadcrumb) contract' (StateImport breadcrumb state) (Succ n) + + pop + :: [FilePath] + -> ClientState node + -> Nat n + -> CLI (ClientStPop n node CLI (Either LoadError DatumHash)) + pop breadcrumb state n = case state of + StateRoot -> pure $ ClientStComplete $ pure . Right + StatePay state' -> pop breadcrumb state' n + StateIfL fal state' -> push breadcrumb fal (StateIfR state') n + StateIfR state' -> pop breadcrumb state' n + StateWhen state' -> pop breadcrumb state' n + StateCase [] fallback state' -> push breadcrumb fallback (StateWhen state') n + StateCase (c : cs) fallback state' -> pushCase breadcrumb n c cs fallback state' + StateLet state' -> pop breadcrumb state' n + StateAssert state' -> pop breadcrumb state' n + StateImport prevBreadcrumb state' -> do + case prevBreadcrumb of + [] -> pure () + prevPath : _ -> setCurrentDirectory $ takeDirectory prevPath + pop prevBreadcrumb state' n + + pushCase + :: [FilePath] + -> Nat n + -> LoadCase + -> [LoadCase] + -> LoadContract + -> ClientState node + -> CLI (ClientStCanPush n ('WhenNode node) CLI (Either LoadError DatumHash)) + pushCase breadcrumb n c cs fallback state = case n of + Zero -> pure $ RequestResume $ ClientStProcessing \n' -> + pushCase' breadcrumb n' c cs fallback state + Succ n' -> pushCase' breadcrumb (Succ n') c cs fallback state + + pushCase' + :: [FilePath] + -> Nat ('S n) + -> LoadCase + -> [LoadCase] + -> LoadContract + -> ClientState node + -> CLI (ClientStCanPush ('S n) ('WhenNode node) CLI (Either LoadError DatumHash)) + pushCase' breadcrumb (Succ n) c cs fallback state = case c of + LoadCase action next -> do + incrementProgress + pure $ PushCase action $ push breadcrumb next (StateCase cs fallback state) n + +data ClientState (node :: Node) where + StateRoot :: ClientState 'RootNode + StatePay :: ClientState node -> ClientState ('PayNode node) + StateIfL :: LoadContract -> ClientState node -> ClientState ('IfLNode node) + StateIfR :: ClientState node -> ClientState ('IfRNode node) + StateWhen :: ClientState node -> ClientState ('WhenNode node) + StateCase :: [LoadCase] -> LoadContract -> ClientState node -> ClientState ('CaseNode node) + StateLet :: ClientState node -> ClientState ('LetNode node) + StateAssert :: ClientState node -> ClientState ('AssertNode node) + StateImport :: [FilePath] -> ClientState node -> ClientState node + +-- A contract that can be loaded. It lacks merkleization and supports +-- file-based imports. +data LoadContract + = Close + | Pay AccountId Payee Token (Value Observation) LoadContract + | If Observation LoadContract LoadContract + | When [LoadCase] Timeout LoadContract + | Let ValueId (Value Observation) LoadContract + | Assert Observation LoadContract + | Import FilePath + +data LoadCase = LoadCase Action LoadContract + +instance FromJSON LoadCase where + parseJSON = withObject "Case" \obj -> + LoadCase <$> (obj .: "case") <*> (obj .: "then") + +instance FromJSON LoadContract where + parseJSON = \case + String "close" -> pure Close + Object + ( KM.toList -> + [ ("import", String path) + ] + ) -> pure $ Import $ T.unpack path + Object + ( sortOn fst . KM.toList -> + [ ("from_account", account) + , ("pay", pay) + , ("then", then_) + , ("to", to) + , ("token", token) + ] + ) -> Pay + <$> parseJSON account Key "from_account" + <*> parseJSON to Key "to" + <*> parseJSON token Key "token" + <*> parseJSON pay Key "pay" + <*> parseJSON then_ Key "then" + Object + ( sortOn fst . KM.toList -> + [ ("else", else_) + , ("if", if_) + , ("then", then_) + ] + ) -> If + <$> parseJSON if_ Key "if" + <*> parseJSON then_ Key "then" + <*> parseJSON else_ Key "else" + Object + ( sortOn fst . KM.toList -> + [ ("timeout", timeout) + , ("timeout_continuation", continuation) + , ("when", when) + ] + ) -> When + <$> parseJSON when Key "when" + <*> (POSIXTime <$> parseJSON timeout Key "timeout") + <*> parseJSON continuation Key "timeout_continuation" + Object + ( sortOn fst . KM.toList -> + [ ("be", value) + , ("let", valueId) + , ("then", then_) + ] + ) -> Let + <$> parseJSON valueId Key "let" + <*> parseJSON value Key "be" + <*> parseJSON then_ Key "then" + Object + ( sortOn fst . KM.toList -> + [ ("assert", obs) + , ("then", then_) + ] + ) -> Assert + <$> parseJSON obs Key "assert" + <*> parseJSON then_ Key "then" + _ -> fail "Expected an object or \"close\"" diff --git a/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Monad.hs b/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Monad.hs index f8daab9cf6..a2eb9de49d 100644 --- a/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Monad.hs +++ b/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Monad.hs @@ -17,6 +17,7 @@ import Language.Marlowe.Protocol.Client (hoistMarloweRuntimeClient) import Language.Marlowe.Runtime.CLI.Env (Env(..)) import Options.Applicative (Alternative) import System.Exit (die) +import UnliftIO (MonadUnliftIO) -- | A monad type for Marlowe Runtime CLI programs. newtype CLI a = CLI { runCLI :: MarloweT (ReaderT Env IO) a } @@ -31,6 +32,7 @@ newtype CLI a = CLI { runCLI :: MarloweT (ReaderT Env IO) a } , MonadPlus , MonadBase IO , MonadBaseControl IO + , MonadUnliftIO ) instance MonadMarlowe CLI where diff --git a/marlowe-runtime-cli/app/Main.hs b/marlowe-runtime-cli/app/Main.hs index 0594c1e9f4..26c75b516f 100644 --- a/marlowe-runtime-cli/app/Main.hs +++ b/marlowe-runtime-cli/app/Main.hs @@ -10,8 +10,8 @@ import Control.Concurrent.STM (atomically, newEmptyTMVarIO, putTMVar, takeTMVar) #endif import GHC.IO.Handle (hSetBuffering) import Language.Marlowe.Runtime.CLI.Command -import System.IO (BufferMode(LineBuffering), stderr, stdout) -import System.Posix (Handler(Catch), installHandler, sigINT) +import System.IO (BufferMode(..), stderr, stdout) +import System.Posix (Handler(..), installHandler, sigINT) main :: IO () main = do @@ -23,7 +23,7 @@ main = do let sigInt = retry #else sigIntVar <- newEmptyTMVarIO - _ <- installHandler sigINT (Catch $ atomically $ putTMVar sigIntVar ()) Nothing + _ <- installHandler sigINT (CatchOnce $ atomically $ putTMVar sigIntVar ()) Nothing let sigInt = takeTMVar sigIntVar #endif runCLIWithOptions sigInt options $ runCommand cmd diff --git a/marlowe-runtime-cli/marlowe-runtime-cli.cabal b/marlowe-runtime-cli/marlowe-runtime-cli.cabal index 699d9e2332..aa02089fd5 100644 --- a/marlowe-runtime-cli/marlowe-runtime-cli.cabal +++ b/marlowe-runtime-cli/marlowe-runtime-cli.cabal @@ -55,6 +55,7 @@ executable marlowe-runtime-cli Language.Marlowe.Runtime.CLI.Command Language.Marlowe.Runtime.CLI.Command.Apply Language.Marlowe.Runtime.CLI.Command.Create + Language.Marlowe.Runtime.CLI.Command.Load Language.Marlowe.Runtime.CLI.Command.Log Language.Marlowe.Runtime.CLI.Command.Submit Language.Marlowe.Runtime.CLI.Command.Tx @@ -65,34 +66,38 @@ executable marlowe-runtime-cli autogen-modules: Paths_marlowe_runtime_cli build-depends: - aeson - , base >= 4.9 && < 5 + , aeson , ansi-terminal + , base >= 4.9 && < 5 , base16 , bytestring , cardano-api , containers , errors + , filepath , marlowe-cardano , marlowe-chain-sync , marlowe-client , marlowe-protocols , marlowe-runtime , marlowe-runtime:config - , marlowe-runtime:tx-api + , marlowe-runtime:contract-api , marlowe-runtime:history-api , marlowe-runtime:proxy-api + , marlowe-runtime:tx-api , monad-control , mtl , network - , plutus-ledger-api - , transformers - , transformers-base , optparse-applicative + , plutus-ledger-api , stm , stm-delay , text , time + , transformers + , transformers-base + , typed-protocols + , unliftio , wl-pprint , yaml if !os(windows)