[cli] fix: move ssh option from anti facts to anti facts test-runs and anti facts test-run done

Author: paolino

cli/src/Cli.hs

@@ -64,8 +64,7 @@ data Command a where
     RetractRequest
         :: MPFSClient -> Wallet -> RequestRefId -> Command TxHash
     GetFacts
-        :: Maybe (SSHClient 'WithSelector)
-        -> MPFSClient
+        :: MPFSClient
         -> TokenId
         -> FactsSelection a
         -> Command a
@@ -123,15 +122,15 @@ cmd = \case
                 $ submit
                 $ \address ->
                     retractChange address refId
-    GetFacts ssh MPFSClient{runMPFS} tokenId factsCommand -> do
+    GetFacts MPFSClient{runMPFS} tokenId factsCommand -> do
         let validation =
                 mkValidation
                     (error "shouldn't need this...")
                     mpfsClient
                     $ Just tokenId
         runMPFS
             $ factsCmd
-                ((,validation) <$> ssh)
+                (Just validation)
                 mpfsClient
                 tokenId
                 factsCommand

cli/src/Facts.hs

@@ -48,15 +48,17 @@ data TestRunSelection a where
         -> All
         -> TestRunSelection [Fact TestRun (TestRunState 'RunningT)]
     TestRunDone
-        :: [TestRunId]
+        :: Maybe (SSHClient 'WithSelector)
+        -> [TestRunId]
         -> All
         -> TestRunSelection [Fact TestRun (TestRunState 'DoneT)]
     TestRunRejected
         :: [TestRunId]
         -> All
         -> TestRunSelection [Fact TestRun (TestRunState 'DoneT)]
     AnyTestRuns
-        :: [TestRunId]
+        :: Maybe (SSHClient 'WithSelector)
+        -> [TestRunId]
         -> All
         -> TestRunSelection [Fact TestRun JSValue]
 data FactsSelection a where
@@ -95,20 +97,20 @@ whoseFilter whose facts = filterOn facts factKey
 factsCmd
     :: forall m a
      . Monad m
-    => Maybe (SSHClient 'WithSelector, Validation m)
+    => Maybe (Validation m)
     -> MPFS m
     -> TokenId
     -> FactsSelection a
     -> m a
-factsCmd mDecrypt mpfs tokenId selection = do
-    decrypt <- case mDecrypt of
-        Nothing -> pure id
-        Just (ssh, validation) -> do
-            users :: [RegisterUserKey] <-
-                fmap factKey <$> retrieveAnyFacts @_ @() mpfs tokenId
-            mk <- decodePrivateSSHFile validation ssh
-            let decrypt = tryDecryption users mk
-            pure decrypt
+factsCmd mValidation mpfs tokenId selection = do
+    let mkDecrypt mDecrypt = case (,) <$> mDecrypt <*> mValidation of
+            Nothing -> pure id
+            Just (ssh, validation) -> do
+                users :: [RegisterUserKey] <-
+                    fmap factKey <$> retrieveAnyFacts @_ @() mpfs tokenId
+                mk <- decodePrivateSSHFile validation ssh
+                let decrypt = tryDecryption users mk
+                pure decrypt
     let
         testRunCommon
             :: FromJSON Maybe x => [TestRunId] -> All -> m [Fact TestRun x]
@@ -122,7 +124,8 @@ factsCmd mDecrypt mpfs tokenId selection = do
             testRunCommon ids whose
         core (TestRunFacts (TestRunRunning ids whose)) = do
             testRunCommon ids whose
-        core (TestRunFacts (TestRunDone ids whose)) = do
+        core (TestRunFacts (TestRunDone mDecrypt ids whose)) = do
+            decrypt <- mkDecrypt mDecrypt
             facts <-
                 testRunCommon ids whose <&> fmap decrypt
             pure $ filterOn facts factValue $ \case
@@ -134,7 +137,8 @@ factsCmd mDecrypt mpfs tokenId selection = do
             pure $ filterOn facts factValue $ \case
                 Rejected{} -> True
                 _ -> False
-        core (TestRunFacts (AnyTestRuns ids whose)) =
+        core (TestRunFacts (AnyTestRuns mDecrypt ids whose)) = do
+            decrypt <- mkDecrypt mDecrypt
             testRunCommon ids whose <&> fmap (parseDecrypt decrypt)
         core ConfigFact = retrieveAnyFacts mpfs tokenId
         core WhiteListedFacts = retrieveAnyFacts mpfs tokenId

cli/src/Options.hs

@@ -113,9 +113,8 @@ commandParser =
             "Retract a request"
             retractRequestOptions
         , command "facts" "Get token facts"
-            $ (\ssh c tk -> fmapBox (GetFacts ssh c tk))
-                <$> optional sshClientOption
-                <*> mpfsClientOption
+            $ (\c tk -> fmapBox (GetFacts c tk))
+                <$> mpfsClientOption
                 <*> tokenIdOption
                 <*> factsSelectionParser
         , command "token" "Get the token content"
@@ -161,13 +160,24 @@ testRunSelectionParser =
         , command
             "done"
             "Get done test runs"
-            (fmap Box $ TestRunDone <$> includedTestRuns <*> whoseOption)
+            ( fmap Box
+                $ TestRunDone
+                    <$> optional sshClientOption
+                    <*> includedTestRuns
+                    <*> whoseOption
+            )
         , command
             "rejected"
             "Get rejected test runs"
             (fmap Box $ TestRunRejected <$> includedTestRuns <*> whoseOption)
         ]
-        <|> fmap Box (AnyTestRuns <$> includedTestRuns <*> whoseOption)
+        <|> fmap
+            Box
+            ( AnyTestRuns
+                <$> optional sshClientOption
+                <*> includedTestRuns
+                <*> whoseOption
+            )
 
 whoseOption :: Parser All
 whoseOption =

cli/src/User/Agent/Process.hs

@@ -362,8 +362,8 @@ pollTestRuns
         } = do
         allTrs <-
             cmd
-                $ GetFacts Nothing poMPFSClient poTokenId
-                $ TestRunFacts (AnyTestRuns [] All)
+                $ GetFacts poMPFSClient poTokenId
+                $ TestRunFacts (AnyTestRuns Nothing [] All)
         let typed :: FromJSON Maybe x => [Fact TestRun x]
             typed = mapMaybe (mapM fromJSON) allTrs
         etoken <- cmd $ GetToken poAuth poMPFSClient poTokenId