[cli] Allow for Validation without a TokenId

Author: paolino

cli/src/Core/Context.hs

@@ -33,7 +33,7 @@ import Validation (Validation)
 -- have a type for each command
 data Context m = Context
     { ctxMPFS :: MPFS m
-    , ctxMkValidation :: TokenId -> Validation m
+    , ctxMkValidation :: Maybe TokenId -> Validation m
     , ctxSubmit :: Wallet -> Submission m
     }
 
@@ -75,7 +75,8 @@ askTestRunConfig tokenId = withConfig tokenId configTestRun
 askAgentPKH :: Monad m => TokenId -> WithContext m (Maybe Owner)
 askAgentPKH tokenId = withConfig tokenId configAgent
 
-askValidation :: Monad m => TokenId -> WithContext m (Validation m)
+askValidation
+    :: Monad m => Maybe TokenId -> WithContext m (Validation m)
 askValidation tokenId = do
     ctx <- WithContext ask
     return $ ctxMkValidation ctx tokenId
@@ -85,7 +86,7 @@ askSubmit = ctxSubmit <$> WithContext ask
 
 withContext
     :: MPFS m
-    -> (TokenId -> Validation m)
+    -> (Maybe TokenId -> Validation m)
     -> (Wallet -> Submission m)
     -> WithContext m a
     -> m a

cli/src/Oracle/Token/Cli.hs

@@ -140,7 +140,7 @@ tokenCmdCore command = do
         GetToken tk -> lift $ mpfsGetToken mpfs tk
         UpdateToken tk wallet wanted -> do
             Submission submit <- ($ wallet) <$> askSubmit
-            validation <- askValidation tk
+            validation <- askValidation $ Just tk
             mconfig <- askConfig tk
             lift $ runValidate $ do
                 when (null wanted) $ notValidated TokenUpdateOfNoRequests

cli/src/Oracle/Validate/Cli.hs

@@ -76,7 +76,7 @@ validateCmd tk command = case command of
     ValidateRequests -> do
         mpfs <- askMpfs
         mconfig <- askConfig tk
-        validation <- askValidation tk
+        validation <- askValidation $ Just tk
         lift $ runValidate $ case command of
             ValidateRequests -> do
                 canonicalJSON <- lift $ mpfsGetToken mpfs tk

cli/src/Oracle/Validate/DownloadAssets.hs

@@ -133,7 +133,7 @@ downloadFileAndWriteLocally
         contentE <-
             githubGetFile
                 (repository testRun)
-                (commitId testRun)
+                (Just $ commitId testRun)
                 (FileName $ sourceDir <> "/" <> filename)
         case contentE of
             Left err -> pure $ Just $ AssetValidationParseError err

cli/src/User/Agent/Cli.hs

@@ -281,7 +281,7 @@ whiteList tokenId wallet platform repo = do
                 , operation = Insert ()
                 }
         requester = owner wallet
-    validation <- askValidation tokenId
+    validation <- askValidation $ Just tokenId
     Submission submit <- ($ wallet) <$> askSubmit
     mpfs <- askMpfs
     mconfig <- askConfig tokenId
@@ -310,7 +310,7 @@ blackList tokenId wallet platform repo = do
     let key = WhiteListKey platform repo
         change = Change (Key key) (Delete ())
         requester = owner wallet
-    validation <- askValidation tokenId
+    validation <- askValidation $ Just tokenId
     Submission submit <- ($ wallet) <$> askSubmit
     mpfs <- askMpfs
     mconfig <- askConfig tokenId
@@ -345,7 +345,7 @@ downloadAssets
     -> WithContext m (AValidationResult DownloadAssetsFailure ())
 downloadAssets tokenId testRunId dir = do
     testmap <- queryCommand tokenId
-    validation <- askValidation tokenId
+    validation <- askValidation $ Just tokenId
     lift $ runValidate $ do
         void $ validateDownloadAssets validation testmap testRunId dir
 
@@ -367,7 +367,7 @@ signAndSubmitAnUpdate
         (AValidationResult UpdateTestRunFailure (WithTxHash new))
 signAndSubmitAnUpdate validate tokenId wallet testRun oldState newState = do
     let requester = owner wallet
-    validation <- askValidation tokenId
+    validation <- askValidation $ Just tokenId
     mconfig <- askConfig tokenId
     Submission submit <- ($ wallet) <$> askSubmit
     mpfs <- askMpfs

cli/src/User/Requester/Cli.hs

@@ -143,7 +143,7 @@ createCommand
     testRun
     duration = do
         mconfig <- askConfig tokenId
-        validation <- askValidation tokenId
+        validation <- askValidation $ Just tokenId
         Submission submit <- ($ wallet) <$> askSubmit
         mpfs <- askMpfs
         lift $ runValidate $ do
@@ -176,7 +176,7 @@ registerUser
     request = do
         mpfs <- askMpfs
         Submission submit <- ($ wallet) <$> askSubmit
-        validation <- askValidation tokenId
+        validation <- askValidation $ Just tokenId
         lift $ runValidate $ do
             void
                 $ validateRegisterUser validation
@@ -201,7 +201,7 @@ unregisterUser
     wallet
     request = do
         mpfs <- askMpfs
-        validation <- askValidation tokenId
+        validation <- askValidation $ Just tokenId
         Submission submit <- ($ wallet) <$> askSubmit
         lift $ runValidate $ do
             void
@@ -227,7 +227,7 @@ registerRole
     wallet
     request = do
         mpfs <- askMpfs
-        validation <- askValidation tokenId
+        validation <- askValidation $ Just tokenId
         Submission submit <- ($ wallet) <$> askSubmit
         lift $ runValidate $ do
             void
@@ -253,7 +253,7 @@ unregisterRole
     wallet
     request = do
         mpfs <- askMpfs
-        validation <- askValidation tokenId
+        validation <- askValidation $ Just tokenId
         Submission submit <- ($ wallet) <$> askSubmit
         lift $ runValidate $ do
             void

cli/src/Validation.hs

@@ -79,7 +79,7 @@ data Validation m = Validation
         -> m (Maybe RepositoryRoleFailure)
     , githubGetFile
         :: Repository
-        -> Commit
+        -> Maybe Commit
         -> FileName
         -> m (Either DownloadedFileFailure Text)
     }
@@ -117,13 +117,14 @@ hoistValidation
                 \repository commit filename -> f $ githubGetFile repository commit filename
             }
 
-mkValidation :: Auth -> TokenId -> Validation ClientM
-mkValidation auth tk =
+mkValidation :: Auth -> Maybe TokenId -> Validation ClientM
+mkValidation auth tk = do
+    let getFacts :: (FromJSON Maybe k, FromJSON Maybe v) => ClientM [Fact k v]
+        getFacts = maybe (pure []) (fmap parseFacts . getTokenFacts) tk
     Validation
-        { mpfsGetFacts = parseFacts <$> getTokenFacts tk
-        , mpfsGetTestRuns = do
-            facts <- parseFacts <$> getTokenFacts tk
-            pure $ mapMaybe (\(Fact k _ :: JSFact) -> fromJSON k) facts
+        { mpfsGetFacts = getFacts
+        , mpfsGetTestRuns =
+            mapMaybe (\(Fact k _ :: JSFact) -> fromJSON k) <$> getFacts
         , githubCommitExists = \repository commit ->
             liftIO $ GitHub.githubCommitExists auth repository commit
         , githubDirectoryExists = \repository commit dir ->

cli/src/Validation/DownloadFile.hs

@@ -76,12 +76,12 @@ inspectDownloadedFileTemplate repo commit filename downloadFile = do
 inspectDownloadedFile
     :: Auth
     -> Repository
-    -> Commit
+    -> Maybe Commit
     -> FileName
     -> IO (Either DownloadedFileFailure Text)
 inspectDownloadedFile auth repo commit filename =
     inspectDownloadedFileTemplate
         repo
-        (Just commit)
+        commit
         filename
         $ githubGetFile auth