Implement ls command

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

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)