[cli] Add anti facts subcommands to select facts by type

Author: paolino

cli/.gitignore

@@ -1 +1,4 @@
 dist-newstyle
+.direnv
+tmp
+result

cli/anti.cabal

@@ -103,6 +103,7 @@ library
     Core.Types.Operation
     Core.Types.Tx
     Core.Types.Wallet
+    Facts
     Lib.Box
     Lib.GitHub
     Lib.JSON.Canonical.Aeson

cli/src/Cli.hs

@@ -11,11 +11,11 @@ import Core.Types.MPFS (MPFSClient (..))
 import Core.Types.Tx (TxHash, WithTxHash (..))
 import Core.Types.Wallet (Wallet)
 import Data.Functor.Identity (Identity (..))
+import Facts (FactsSelection, factsCmd)
 import Lib.GitHub (getOAUth)
 import Lib.JSON.Canonical.Extra
 import MPFS.API
     ( MPFS (..)
-    , getTokenFacts
     , mpfsClient
     , retractChange
     )
@@ -34,7 +34,7 @@ import Oracle.Validate.Types
     , runValidate
     )
 import Submitting (Submission (..))
-import Text.JSON.Canonical (FromJSON (..), JSValue, ToJSON (..))
+import Text.JSON.Canonical (FromJSON (..), ToJSON (..))
 import User.Agent.Cli
     ( AgentCommand (..)
     , IsReady (NotReady)
@@ -53,7 +53,7 @@ data Command a where
     AgentCommand :: MPFSClient -> AgentCommand NotReady a -> Command a
     RetractRequest
         :: MPFSClient -> Wallet -> RequestRefId -> Command TxHash
-    GetFacts :: MPFSClient -> TokenId -> Command JSValue
+    GetFacts :: MPFSClient -> TokenId -> FactsSelection a -> Command a
     Wallet :: WalletCommand a -> Command a
     GetToken
         :: MPFSClient
@@ -106,8 +106,8 @@ cmd = \case
                 $ submit
                 $ \address ->
                     retractChange address refId
-    GetFacts MPFSClient{runMPFS} tokenId -> do
-        runMPFS $ getTokenFacts tokenId
+    GetFacts MPFSClient{runMPFS} tokenId factsCommand ->
+        runMPFS $ factsCmd mpfsClient tokenId factsCommand
     Wallet walletCommand -> liftIO $ walletCmd walletCommand
     GetToken
         MPFSClient{runMPFS, submitTx}

cli/src/Facts.hs

@@ -0,0 +1,62 @@
+module Facts
+    ( FactsSelection (..)
+    , TestRunSelection (..)
+    , factsCmd
+    )
+where
+
+import Core.Types.Basic (TokenId)
+import Core.Types.Fact (Fact (..), parseFacts)
+import MPFS.API (MPFS, mpfsGetTokenFacts)
+import Text.JSON.Canonical
+import User.Types
+    ( Phase (..)
+    , RegisterUserKey
+    , TestRun
+    , TestRunState (..)
+    )
+
+data TestRunSelection a where
+    TestRunPending
+        :: TestRunSelection [Fact TestRun (TestRunState 'PendingT)]
+    TestRunRunning
+        :: TestRunSelection [Fact TestRun (TestRunState 'RunningT)]
+    TestRunDone :: TestRunSelection [Fact TestRun (TestRunState 'DoneT)]
+    TestRunRejected
+        :: TestRunSelection [Fact TestRun (TestRunState 'DoneT)]
+data FactsSelection a where
+    UserFacts :: FactsSelection [Fact RegisterUserKey ()]
+    RoleFacts :: FactsSelection [Fact RegisterUserKey ()]
+    TestRunFacts :: TestRunSelection a -> FactsSelection a
+    AllFacts :: FactsSelection [Fact JSValue JSValue]
+retrieveAnyFacts
+    :: (FromJSON Maybe k, FromJSON Maybe v, Functor m)
+    => MPFS m
+    -> TokenId
+    -> m [Fact k v]
+retrieveAnyFacts mpfs tokenId = parseFacts <$> mpfsGetTokenFacts mpfs tokenId
+
+factsCmd :: Monad m => MPFS m -> TokenId -> FactsSelection a -> m a
+factsCmd mpfs tokenId UserFacts = retrieveAnyFacts mpfs tokenId
+factsCmd mpfs tokenId RoleFacts = retrieveAnyFacts mpfs tokenId
+factsCmd mpfs tokenId (TestRunFacts TestRunPending) = retrieveAnyFacts mpfs tokenId
+factsCmd mpfs tokenId (TestRunFacts TestRunRunning) = retrieveAnyFacts mpfs tokenId
+factsCmd mpfs tokenId (TestRunFacts TestRunDone) = do
+    facts <- retrieveAnyFacts mpfs tokenId
+    pure
+        $ filter
+            ( \v -> case factValue v of
+                Finished{} -> True
+                _ -> False
+            )
+            facts
+factsCmd mpfs tokenId (TestRunFacts TestRunRejected) = do
+    facts <- retrieveAnyFacts mpfs tokenId
+    pure
+        $ filter
+            ( \v -> case factValue v of
+                Rejected{} -> True
+                _ -> False
+            )
+            facts
+factsCmd mpfs tokenId AllFacts = retrieveAnyFacts mpfs tokenId

cli/src/Options.hs

@@ -20,18 +20,20 @@ import Core.Options
     )
 import Core.Types.MPFS (mpfsClientOption)
 import Data.Version (Version)
+import Facts (FactsSelection (..), TestRunSelection (..))
 import Lib.Box (Box (..), fmapBox)
 import MPFS.API (mpfsClient)
 import OptEnvConf
     ( Parser
     , command
     , commands
-    , runParser
+    , runParser, (<|>)
     )
 import Oracle.Options (oracleCommandParser)
 import User.Agent.Options (agentCommandParser)
 import User.Requester.Options (requesterCommandParser)
 import Wallet.Options (walletCommandParser)
+import Control.Applicative (optional)
 
 newtype Options a = Options
     { optionsCommand :: Command a
@@ -59,11 +61,37 @@ commandParser =
             "Retract a request"
             retractRequestOptions
         , command "facts" "Get token facts"
-            $ fmap Box . GetFacts <$> mpfsClientOption <*> tokenIdOption
+            $ (\c tk -> fmapBox (GetFacts c tk))
+                <$> mpfsClientOption
+                <*> tokenIdOption
+                <*> factsSelectionParser
         , command "token" "Get the token content"
             $ fmap Box . GetToken <$> mpfsClientOption <*> tokenIdOption
         ]
 
+factsSelectionParser :: Parser (Box FactsSelection)
+factsSelectionParser =
+    commands
+        [ command "user" "Get registered users" (pure $ Box UserFacts)
+        , command "role" "Get registered roles" (pure $ Box RoleFacts)
+        , command
+            "test-run"
+            "Get test runs"
+            (fmapBox TestRunFacts <$> testRunSelectionParser)
+        ] <|> pure (Box AllFacts)
+
+testRunSelectionParser :: Parser (Box TestRunSelection)
+testRunSelectionParser =
+    commands
+        [ command "pending" "Get pending test runs" (pure $ Box TestRunPending)
+        , command "running" "Get running test runs" (pure $ Box TestRunRunning)
+        , command "done" "Get done test runs" (pure $ Box TestRunDone)
+        , command
+            "rejected"
+            "Get rejected test runs"
+            (pure $ Box TestRunRejected)
+        ]
+
 optionsParser :: Parser (Box Options)
 optionsParser = fmapBox Options <$> commandParser