feat: delete single test campaign DAC-361

input-output-hk · Feb 6, 2023 · 46624ba · 46624ba
1 parent e0553d9
commit 46624ba
Show file tree

Hide file tree

Showing 5 changed files with 29 additions and 14 deletions.
diff --git a/client/Main.hs b/client/Main.hs
@@ -111,6 +111,12 @@ abortRunParser :: Parser AbortRunArgs
 abortRunParser = AbortRunArgs
   <$> getRunParser
   <*> publicKeyParser
+  <*> optional ( option auto
+        ( long "delete-run"
+       <> metavar "DELETE_RUN"
+       <> help "to delete the run from db as well"
+        )
+      )
 
 generalReader :: FromHttpApiData a => ReadM a
 generalReader = do
@@ -173,7 +179,8 @@ data CreateRunArgs = CreateRunArgs !CommitOrBranch !PublicKey
 
 data GetRunsArgs = GetRunsArgs !PublicKey !(Maybe UTCTime) !(Maybe Int)
 
-data AbortRunArgs = AbortRunArgs !RunIDV1 !PublicKey
+type DeleteRun = Maybe Bool
+data AbortRunArgs = AbortRunArgs !RunIDV1 !PublicKey !DeleteRun
 data CreateCertificationArgs= CreateCertificationArgs !RunIDV1 !PublicKey
 
 data GetLogsArgs = GetLogsArgs
@@ -354,8 +361,8 @@ main = do
       handle $ apiClient.createRun (addAuth pubKey) ref
     CmdRun (Get ref) ->
       handle $ apiClient.getRun ref
-    CmdRun (Abort (AbortRunArgs ref pubKey)) ->
-      handle $ (const True <$> apiClient.abortRun (addAuth pubKey) ref)
+    CmdRun (Abort (AbortRunArgs ref pubKey deleteRun)) ->
+      handle $ (const True <$> apiClient.abortRun (addAuth pubKey) ref deleteRun)
     --TODO: investigate why ZonedTime doesn't serialize properly
     CmdRun (GetLogs (GetLogsArgs ref zt act)) ->
       handle $ apiClient.getLogs ref zt act

diff --git a/dapps-certification-persistence/src/IOHK/Certification/Persistence.hs b/dapps-certification-persistence/src/IOHK/Certification/Persistence.hs
@@ -30,4 +30,5 @@ import IOHK.Certification.Persistence.API as X
   , getRunOwner
   , getCertification
   , createCertificate
+  , deleteRun
   )
diff --git a/dapps-certification-persistence/src/IOHK/Certification/Persistence/API.hs b/dapps-certification-persistence/src/IOHK/Certification/Persistence/API.hs
@@ -128,6 +128,10 @@ syncRun runId time= update runs
     (\run -> run ! #runId .== literal runId)
     (`with` [ #syncedAt := literal time ])
 
+deleteRun :: MonadSelda m => UUID -> m Int
+deleteRun runId = deleteFrom runs
+  (\run -> (run ! #runId .== literal runId ) .&& (run ! #runStatus ./= literal Certified))
+
 createCertificate :: (MonadSelda m,MonadMask m)
                   => UUID
                   -> IpfsCid

diff --git a/src/Plutus/Certification/API/Routes.hs b/src/Plutus/Certification/API/Routes.hs
@@ -60,6 +60,7 @@ type AbortRunRoute = "run"
   :> Description "Abort a run"
   :> AuthProtect "public-key"
   :> Capture "id" RunIDV1
+  :> QueryParam "delete" Bool
   :> DeleteNoContent
 
 type GetLogsRoute = "run"

diff --git a/src/Plutus/Certification/Server.hs b/src/Plutus/Certification/Server.hs
@@ -143,20 +143,22 @@ server ServerCaps {..} wargs eb = NamedAPI
         $ getRuns (setAncestor $ reference ev) rid .| evalStateC Queued consumeRuns
       ) >>= dbSync uuid
 
-  , abortRun = \(profileId,_) rid@RunID{..} -> withEvent eb AbortRun \ev -> do
+  , abortRun = \(profileId,_) rid@RunID{..} deleteRun -> withEvent eb AbortRun \ev -> do
       addField ev rid
-      -- ensure is no already finished
+      requireRunIdOwner profileId uuid
+      -- abort the run if is still running
       status <- runConduit $
         getRuns (setAncestor $ reference ev) rid .| evalStateC Queued consumeRuns
-      unless (toDbStatus status == DB.Queued) $
-        throwError err403 { errBody = "Run already finished"}
-      requireRunIdOwner profileId uuid
-      -- finally abort the run
-      resp <- const NoContent <$> (abortRuns (setAncestor $ reference ev) rid)
-      -- if abortion succeeded mark it in the db
-      void (getNow >>= DB.withDb . DB.updateFinishedRun uuid False)
-
-      pure resp
+      when (toDbStatus status == DB.Queued) $ do
+        -- finally abort the run
+        (abortRuns (setAncestor $ reference ev) rid)
+        -- if abortion succeeded mark it in the db
+        void (getNow >>= DB.withDb . DB.updateFinishedRun uuid False)
+
+      when (deleteRun == Just True) $
+        -- detele the run from the db
+        void (DB.withDb $ DB.deleteRun uuid)
+      pure NoContent
   , getLogs = \rid afterM actionTypeM -> withEvent eb GetRunLogs \ev -> do
       addField ev rid
       let dropCond = case afterM of