From bfe18b52c2f3f40d2e791b7a233715842f0a5f9e Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Mon, 26 Sep 2022 15:58:00 -0400 Subject: [PATCH] Implement ls command --- .../Marlowe/Runtime/CLI/Command/Ls.hs | 67 +++++++++++++++++-- .../cli/Language/Marlowe/Runtime/CLI/Monad.hs | 36 ++++++---- 2 files changed, 87 insertions(+), 16 deletions(-) diff --git a/marlowe-runtime/cli/Language/Marlowe/Runtime/CLI/Command/Ls.hs b/marlowe-runtime/cli/Language/Marlowe/Runtime/CLI/Command/Ls.hs index a53902e229..fae65d494d 100644 --- a/marlowe-runtime/cli/Language/Marlowe/Runtime/CLI/Command/Ls.hs +++ b/marlowe-runtime/cli/Language/Marlowe/Runtime/CLI/Command/Ls.hs @@ -1,13 +1,72 @@ module Language.Marlowe.Runtime.CLI.Command.Ls where -import Language.Marlowe.Runtime.CLI.Monad (CLI) +import Control.Monad.IO.Class (liftIO) +import Data.Functor (void) +import qualified Data.Map as Map +import qualified Data.Text.IO as T +import Data.Void (absurd) +import Language.Marlowe.Runtime.CLI.Monad (CLI, runHistoryQueryClient) +import Language.Marlowe.Runtime.Core.Api (renderContractId) +import Language.Marlowe.Runtime.History.Api (FollowerStatus(..), HistoryQuery(..)) +import Network.Protocol.Query.Client import Options.Applicative -data LsCommand +data LsStatusFlag + = LsShowStatus + | LsHideStatus + deriving (Show, Eq) + +data LsFailedFlag + = LsShowFailed + | LsHideFailed + deriving (Show, Eq) + +data LsCommand = LsCommand + { statusFlag:: LsStatusFlag + , failedFlag :: LsFailedFlag + } deriving (Show, Eq) lsCommandParser :: ParserInfo LsCommand -lsCommandParser = error "not implemented" +lsCommandParser = info parser $ progDesc "List managed contracts" + where + parser = LsCommand <$> statusFlagParser <*> failedFlagParser + statusFlagParser = flag LsHideStatus LsShowStatus $ mconcat + [ long "show-status" + , short 's' + , help "Show the status of the contract as well as its ID" + ] + failedFlagParser = flag LsHideFailed LsShowFailed $ mconcat + [ long "show-failed" + , short 'f' + , help "Include contracts whose follower encountered an error" + ] runLsCommand :: LsCommand -> CLI () -runLsCommand = error "not implemented" +runLsCommand LsCommand{..} = runHistoryQueryClient + $ QueryClient + $ pure + $ SendMsgRequest GetFollowedContracts ClientStNextCanReject + { recvMsgReject = absurd + , recvMsgNextPage = handleNextPage + } + where + handleNextPage results nextPage = do + void $ Map.traverseWithKey printResult $ Map.filter filterResult results + pure $ maybe + (SendMsgDone ()) + (flip SendMsgRequestNext $ ClientStNext handleNextPage) + nextPage + filterResult = case failedFlag of + LsShowFailed -> const True + LsHideFailed -> \case + Failed _ -> False + _ -> True + printResult = case statusFlag of + LsHideStatus -> const . printContractId + LsShowStatus -> printStatus + printContractId = liftIO . T.putStrLn . renderContractId + printStatus contractId status = liftIO do + T.putStr $ renderContractId contractId + putStr " Status: " + print status diff --git a/marlowe-runtime/cli/Language/Marlowe/Runtime/CLI/Monad.hs b/marlowe-runtime/cli/Language/Marlowe/Runtime/CLI/Monad.hs index d03c58043d..849fa98aa8 100644 --- a/marlowe-runtime/cli/Language/Marlowe/Runtime/CLI/Monad.hs +++ b/marlowe-runtime/cli/Language/Marlowe/Runtime/CLI/Monad.hs @@ -8,16 +8,16 @@ import Control.Monad (MonadPlus, (>=>)) import Control.Monad.Base (MonadBase) import Control.Monad.Fix (MonadFix) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Reader (ReaderT, ask, asks, local) import Data.Void (Void) -import Language.Marlowe.Protocol.Sync.Client (MarloweSyncClient) +import Language.Marlowe.Protocol.Sync.Client (MarloweSyncClient, hoistMarloweSyncClient) import Language.Marlowe.Runtime.CLI.Env (Env(..)) import Language.Marlowe.Runtime.History.Api (HistoryCommand, HistoryQuery) import Language.Marlowe.Runtime.Transaction.Api (MarloweTxCommand) -import Network.Protocol.Job.Client (JobClient, liftCommand) -import Network.Protocol.Query.Client (QueryClient, liftQuery) +import Network.Protocol.Job.Client (JobClient, hoistJobClient, liftCommand) +import Network.Protocol.Query.Client (QueryClient, hoistQueryClient, liftQuery) import Options.Applicative (Alternative) import System.Exit (die) @@ -49,20 +49,32 @@ localEnv :: (Env IO -> Env IO) -> CLI a -> CLI a localEnv f = CLI . local f . runCLI -- | Run a History Job client. -runHistoryJobClient :: JobClient HistoryCommand IO a -> CLI a -runHistoryJobClient client = liftIO . ($ client) =<< asksEnv envRunHistoryJobClient +runHistoryJobClient :: JobClient HistoryCommand CLI a -> CLI a +runHistoryJobClient client = do + Env{..} <- askEnv + liftBaseWith \runInBase -> + envRunHistoryJobClient $ hoistJobClient runInBase client -- | Run a History Query client. -runHistoryQueryClient :: QueryClient HistoryQuery IO a -> CLI a -runHistoryQueryClient client = liftIO . ($ client) =<< asksEnv envRunHistoryQueryClient +runHistoryQueryClient :: QueryClient HistoryQuery CLI a -> CLI a +runHistoryQueryClient client = do + Env{..} <- askEnv + liftBaseWith \runInBase -> + envRunHistoryQueryClient $ hoistQueryClient runInBase client -- | Run a Marlowe Sync client. -runHistorySyncClient :: MarloweSyncClient IO a -> CLI a -runHistorySyncClient client = liftIO . ($ client) =<< asksEnv envRunHistorySyncClient +runHistorySyncClient :: MarloweSyncClient CLI a -> CLI a +runHistorySyncClient client = do + Env{..} <- askEnv + liftBaseWith \runInBase -> + envRunHistorySyncClient $ hoistMarloweSyncClient runInBase client -- | Run a Tx Job client. -runTxJobClient :: JobClient MarloweTxCommand IO a -> CLI a -runTxJobClient client = liftIO . ($ client) =<< asksEnv envRunTxJobClient +runTxJobClient :: JobClient MarloweTxCommand CLI a -> CLI a +runTxJobClient client = do + Env{..} <- askEnv + liftBaseWith \runInBase -> + envRunTxJobClient $ hoistJobClient runInBase client -- | Run a simple History command. runHistoryCommand :: HistoryCommand Void err result -> CLI (Either err result)