feat: certification payment (DAC-426)

- scanning the wallet transactions and computing the total amount of Ada received from every profile address
- any Run campaign has a desired amount to be paid by the user in order to broadcast the certification
- we expose a balance route to see what are the available tokens to be used by the user ( = total_ada_sent - already_certified_runs_costs )
- now we have an extra state of every run: ReadyForCertification. This status is an intermediate status triggered by the user when he decides to certify a campaign. It will stay in this state until the wallet receives enough Ada for the certification to be issued

.gitignore

@@ -13,3 +13,4 @@ docker/
 Makefile
 *.sqlite
 react-web/node_modules/
+*.ignore.*

cabal.project

@@ -1,4 +1,4 @@
-index-state: 2022-10-13T00:00:00Z
+index-state: 2023-01-25T00:00:00Z
 packages: . dapps-certification-interface dapps-certification-helpers dapps-certification-persistence
 package plutus-certification
   ghc-options: -Wall

client/Main.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -17,13 +16,12 @@ import Network.HTTP.Client.TLS
 import Options.Applicative
 import Control.Exception hiding (handle)
 import Data.UUID as UUID
-import Data.ByteString.Char8 as BS hiding (hPutStrLn)
-import Data.ByteString.Lazy.Char8 (hPutStrLn)
+import Data.ByteString.Char8 as BS
+import Data.ByteString.Lazy.Char8 as LBS (putStrLn)
 import Data.Coerce
 import Network.URI hiding (scheme)
 import Servant.API hiding (addHeader)
 import Data.Aeson
-import System.IO (stdout)
 import Data.Time.LocalTime
 import Data.Time
 import Data.Text as Text
@@ -42,10 +40,10 @@ flakeRefReader = do
 
 createRunParser :: Parser CreateRunArgs
 createRunParser = CreateRunArgs
-  <$> (CommitOrBranch <$> (option str
+  <$> (CommitOrBranch <$> option str
     ( metavar "REF"
    <> help "the flake reference pointing to the repo to build"
-    )))
+    ))
   <*> publicKeyParser
 
 createRunInfo :: ParserInfo CreateRunArgs
@@ -308,9 +306,9 @@ data UpdateCurrentProfileArgs = UpdateCurrentProfileArgs PublicKey ProfileBody
 commandParser :: Parser Command
 commandParser = hsubparser
   ( command "run" (CmdRun <$> runCommandInfo)
- <> command "version" (const CmdVersion <$> versionCommandInfo)
+ <> command "version" (CmdVersion <$ versionCommandInfo)
  <> command "profile" (CmdCurrentProfile <$> currentProfileInfo)
- <> command "wallet-address" (const CmdWalletAddress <$> walletAddressCommandInfo)
+ <> command "wallet-address" (CmdWalletAddress <$ walletAddressCommandInfo)
   )
 
 data Args = Args
@@ -335,9 +333,9 @@ argsParser = Args
        <> metavar "CERTIFICATION_URL"
        <> help "URL of the certification server"
        <> showDefaultWith showBaseUrl
-       <> (value $ BaseUrl Https "testing.dapps.iog.io" 443 "")
+       <> value (BaseUrl Https "testing.dapps.iog.io" 443 "")
         )
-  <*> (optional $ option str
+  <*> optional ( option str
         ( long "user"
        <> metavar "USER"
        <> help "User name for BASIC authentication with the certification server"
@@ -350,7 +348,7 @@ argsInfo = info (argsParser <**> helper)
  <> header "plutus-certification-cli — A tool for interacting with the Plutus Certification service"
   )
 addAuth :: PublicKey -> AuthenticatedRequest (AuthProtect "public-key")
-addAuth = flip mkAuthenticatedRequest (\v -> addHeader hAuthorization (BS.unpack v))
+addAuth = flip mkAuthenticatedRequest (addHeader hAuthorization . BS.unpack)
 
 type instance AuthClientData (AuthProtect "public-key") = PublicKey
 
@@ -361,7 +359,7 @@ main = do
   let apiClient = client $ Proxy @API
       cEnv = mkClientEnv manager args.certificationURL
       handle :: (ToJSON a) => ClientM a -> IO ()
-      handle c = runClientM c cEnv >>= either throwIO (hPutStrLn stdout . encode)
+      handle c = runClientM c cEnv >>= either throwIO (LBS.putStrLn . encode)
   case args.cmd of
     CmdVersion ->
       handle $ apiClient.version
@@ -372,7 +370,7 @@ main = do
     CmdRun (Get ref) ->
       handle $ apiClient.getRun ref
     CmdRun (Abort (AbortRunArgs ref pubKey deleteRun)) ->
-      handle $ (const True <$> apiClient.abortRun (addAuth pubKey) ref deleteRun)
+      handle (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
@@ -381,7 +379,7 @@ main = do
     CmdRun (GetCertification ref) ->
       handle $ apiClient.getCertification ref
     CmdRun (CreateCertification (CreateCertificationArgs ref pubKey)) ->
-      handle $ apiClient.createCertification (addAuth pubKey) ref
+      handle (True <$ apiClient.createCertification (addAuth pubKey) ref)
     CmdCurrentProfile (GetCurrentProfile pubKey) ->
       handle $ apiClient.getCurrentProfile (addAuth pubKey)
     CmdCurrentProfile (UpdateCurrentProfile (UpdateCurrentProfileArgs pubKey profileBody)) ->

dapps-certification-persistence/src/IOHK/Certification/Persistence.hs

@@ -14,9 +14,13 @@ import IOHK.Certification.Persistence.Structure as X
   , ProfileId
   , IpfsCid(..)
   , TxId(..)
+  , Transaction(..)
+  , TxStatus(..)
+  , TransactionEntry(..)
   )
 import IOHK.Certification.Persistence.API as X
   ( upsertProfile
+  , upsertTransaction
   , getProfile
   , getProfileDApp
   , createRun
@@ -31,4 +35,10 @@ import IOHK.Certification.Persistence.API as X
   , getCertification
   , createCertificate
   , deleteRun
+  , getRunStatus
+  , markAsReadyForCertification
+  , getAllCertifiedRunsForAddress
+  , getRunsToCertify
+  , getAllAmountsForAddress
+  , getProfileBalance
   )

dapps-certification-persistence/src/IOHK/Certification/Persistence/API.hs

@@ -1,16 +1,89 @@
+{-# LANGUAGE OverloadedLabels    #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeOperators       #-}
 
 module IOHK.Certification.Persistence.API where
 
-import Database.Selda
-import Database.Selda.SQLite
-import IOHK.Certification.Persistence.Structure
-import Data.Maybe
-import Control.Monad
+import           Control.Monad
+import           Data.Maybe
+import           Database.Selda
+import           Database.Selda.SQLite
+import           IOHK.Certification.Persistence.Structure
+
+getTransactionIdQ:: Text -> Query t (Col t (ID Transaction))
+getTransactionIdQ  externalAddress = do
+  p <- select transactions
+  restrict (p ! #wtxExternalId .== text externalAddress)
+  pure (p ! #wtxId)
+
+getTransactionId :: MonadSelda m => Text -> m (Maybe (ID Transaction))
+getTransactionId = fmap listToMaybe . query . getTransactionIdQ
+
+-- | inserts or updates a transaction
+-- NOTE: if the transaction exists Nothing will be returned and entries
+-- will not be updated
+upsertTransaction :: (MonadSelda m,MonadMask m)
+                  => Transaction
+                  -> [TransactionEntry]
+                  -> m (Maybe (ID Transaction))
+upsertTransaction tx@Transaction{..} entries = do
+  txIdM <- upsert transactions
+     (\p -> p ! #wtxExternalId .== literal wtxExternalId)
+     (`with`
+      [ #wtxExternalId := literal wtxExternalId
+      , #wtxAmount := literal wtxAmount
+      , #wtxTime := literal wtxTime
+      , #wtxDepth := literal wtxDepth
+      , #wtxStatus := literal wtxStatus
+      , #wtxMetadata := literal wtxMetadata
+      ])
+     [tx { wtxId = def :: ID Transaction}]
+  -- if transaction was just inserted , insert entries as well
+  -- otherwise we don't care to update entries
+  let updateEntries txId' = flip fmap entries $
+        \t -> t { txEntryTxId = txId', txEntryId = def :: ID TransactionEntry }
+  forM_ txIdM (insert transactionEntries . updateEntries)
+  pure txIdM
+
+-- get all ready for certification runs
+-- in ascending order
+getRunsToCertify :: MonadSelda m => m [Run]
+getRunsToCertify = query $ do
+  run <- select runs
+  restrict (run ! #runStatus .== literal ReadyForCertification)
+  order (run ! #created) ascending
+  pure run
+
+getAllCertifiedRunsForAddress :: MonadSelda m => Text -> m [Run]
+getAllCertifiedRunsForAddress address = query $ do
+  -- get the profile id for the address
+  profileId <- getProfileIdQ address
+  run <- select runs
+  restrict (run ! #profileId .== profileId)
+  restrict (run ! #runStatus .== literal Certified)
+  order (run ! #created) descending
+  pure run
+
+-- | get all available balance for a given address
+-- | this is the sum of all the transactions minus the cost of all the certified runs
+-- | if the address is not a profile owner Nothing will be returned
+getProfileBalance :: MonadSelda m => Text -> m (Maybe Int)
+getProfileBalance address = do
+  profileIdM <- getProfileId address
+  case profileIdM of
+    Nothing -> pure Nothing
+    Just _ -> do
+      -- get all certified runs
+      certifiedRuns <- getAllCertifiedRunsForAddress address
+      -- get all the amounts coming from this address
+      amountsFromAddress <- sum <$> getAllAmountsForAddress address
+      -- sum all the costs of the certified runs
+      let certifiedCosts = sum $ map certificationPrice certifiedRuns
+          -- calculate the amount of credits available
+          creditsAvailable = amountsFromAddress - certifiedCosts
+      pure $ Just creditsAvailable
 
 upsertProfile :: (MonadSelda m, MonadMask m) => Profile -> Maybe DApp -> m (Maybe (ID Profile))
 upsertProfile profile@Profile{..} dappM = do
@@ -70,7 +143,7 @@ getProfile :: MonadSelda m => ID Profile -> m (Maybe ProfileDTO)
 getProfile pid = fmap (fmap toProfileDTO . listToMaybe ) $ query $ getProfileQ pid
 
 getProfileDApp :: MonadSelda m => ID Profile -> m (Maybe DApp)
-getProfileDApp pid = fmap (listToMaybe ) $ query $ getProfileDAppQ pid
+getProfileDApp pid = fmap listToMaybe $ query $ getProfileDAppQ pid
 
 toProfileDTO :: (Profile :*: Maybe DApp) -> ProfileDTO
 toProfileDTO (profile :*: dapp) = ProfileDTO{..}
@@ -99,22 +172,32 @@ createRun :: MonadSelda m
           -> Text
           -> UTCTime
           -> CommitHash
+          -> CertificationPrice
           -> ID Profile
           -> m ()
-createRun runId time repo commitDate commitHash pid = do
-  void $ insert runs [Run runId time (Just time) time repo commitDate commitHash Queued pid]
+createRun runId time repo commitDate commitHash certificationPrice pid = void $
+  insert runs [Run runId time (Just time) time repo
+    commitDate commitHash Queued pid certificationPrice Nothing]
 
 getRunOwnerQ :: UUID -> Query t (Col t (ID Profile))
 getRunOwnerQ runId = do
     p <- select runs
     restrict (p ! #runId .== literal runId )
     pure (p ! #profileId)
 
+getAllAmountsForAddress :: MonadSelda m => Text -> m [Int]
+getAllAmountsForAddress address = query $ do
+  input <- select transactionEntries
+  restrict (input ! #txEntryAddress .== literal address .&& input ! #txEntryInput .== literal True)
+  t <- innerJoin (\t -> (t ! #wtxId .== (input ! #txEntryTxId))
+      .&& (t ! #wtxStatus .== literal InLedger)) (select transactions)
+  pure (t ! #wtxAmount)
+
 getRunOwner :: MonadSelda m => UUID -> m (Maybe (ID Profile))
 getRunOwner = fmap listToMaybe . query . getRunOwnerQ
 
 updateFinishedRun :: MonadSelda m => UUID -> Bool -> UTCTime -> m Int
-updateFinishedRun runId succeeded time= do
+updateFinishedRun runId succeeded time = do
   update runs
     (\run -> (run ! #runId .== literal runId) .&& (run ! #runStatus .== literal Queued))
     (`with`
@@ -131,19 +214,32 @@ syncRun runId time= update runs
 
 deleteRun :: MonadSelda m => UUID -> m Int
 deleteRun runId = deleteFrom runs
-  (\run -> (run ! #runId .== literal runId ) .&& (run ! #runStatus ./= literal Certified))
+  (\run -> (run ! #runId .== literal runId )
+  .&& ((run ! #runStatus ./= literal Certified)
+  .|| (run ! #runStatus ./= literal ReadyForCertification)))
+
+markAsReadyForCertification :: (MonadSelda m,MonadMask m)
+                            => UUID
+                            -> IpfsCid
+                            -> UTCTime
+                            -> m Int
+markAsReadyForCertification runId IpfsCid{..}  time = update runs
+  (\run -> (run ! #runId .== literal runId) .&& (run ! #runStatus .== literal Succeeded))
+  (`with` [ #runStatus := literal ReadyForCertification
+          , #syncedAt := literal time
+          , #reportContentId := literal (Just ipfsCid)
+          ])
 
 createCertificate :: (MonadSelda m,MonadMask m)
                   => UUID
-                  -> IpfsCid
                   -> TxId
                   -> UTCTime
                   -> m (Maybe Certification)
-createCertificate runId IpfsCid{..} TxId{..} time = transaction $ do
+createCertificate runId TxId{..} time = transaction $ do
   result <- query $ do
     run <- select runs
     restrict (run ! #runId .== literal runId)
-    restrict ( run ! #runStatus .== literal Succeeded)
+    restrict ( run ! #runStatus .== literal ReadyForCertification)
     pure run
   case result of
     [_] -> do
@@ -152,9 +248,9 @@ createCertificate runId IpfsCid{..} TxId{..} time = transaction $ do
         (`with` [ #runStatus := literal Certified
                 , #syncedAt := literal time
                 ])
-      let cert = Certification runId ipfsCid txId time
+      let cert = Certification runId txId time
       _ <- insert certifications [cert]
-      pure $ Just $ cert
+      pure $ Just cert
     _ -> pure Nothing
 
 getCertificationQuery :: UUID -> Query t (Row t Certification)
@@ -167,23 +263,29 @@ getCertification :: MonadSelda m => UUID -> m (Maybe Certification)
 getCertification = fmap listToMaybe . query . getCertificationQuery
 
 getRun :: MonadSelda m => UUID -> m (Maybe Run)
-getRun rid = listToMaybe <$> (query $ do
+getRun rid = listToMaybe <$> query (do
   run <- select runs
   restrict (run ! #runId .== literal rid)
   pure run)
 
+getRunStatus :: MonadSelda m => UUID -> m (Maybe Status)
+getRunStatus rid = listToMaybe <$> query (do
+  run <- select runs
+  restrict (run ! #runId .== literal rid)
+  pure (run ! #runStatus))
+
 getRuns :: MonadSelda m => ID Profile -> Maybe UTCTime -> Maybe Int -> m [Run]
 getRuns pid afterM topM = query $
   case topM of
     Just top -> limit 0 top select'
-    Nothing -> select'
+    Nothing  -> select'
   where
   select' = do
     run <- select runs
     restrict (run ! #profileId .== literal pid)
     case afterM of
       Just after -> restrict (run ! #created .< literal after)
-      Nothing -> pure ()
+      Nothing    -> pure ()
     order (run ! #created) descending
     pure run