feat: introduction of ProfileWallet mechanism ( PLT-5296 )

client/Main.hs

@@ -223,6 +223,22 @@ currentProfileParser :: Parser ProfileCommand
 currentProfileParser = hsubparser
   ( command "get" (GetCurrentProfile <$> getCurrentProfileInfo)
  <> command "update" (UpdateCurrentProfile <$> updateCurrentProfileInfo)
+ <> command "get-wallet-address" (GetProfileWalletAddress <$> getWalletAddressInfo)
+ <> command "get-balance" (GetProfileBalance <$> getBalanceInfo)
+  )
+
+getBalanceInfo :: ParserInfo Auth
+getBalanceInfo = info authParser
+  ( fullDesc
+  <> header "plutus-certification-client profile get-balance — Get the balance of the current profile"
+  )
+
+
+
+getWalletAddressInfo :: ParserInfo Auth
+getWalletAddressInfo = info authParser
+  ( fullDesc
+  <> header "plutus-certification-client profile get-wallet-address — Get the wallet address of the current profile"
   )
 
 updateCurrentProfileInfo :: ParserInfo UpdateCurrentProfileArgs
@@ -384,6 +400,8 @@ data GetRepositoryInfoArgs = GetGitHubAddressArgs
 data ProfileCommand
     = GetCurrentProfile !Auth
     | UpdateCurrentProfile !UpdateCurrentProfileArgs
+    | GetProfileWalletAddress !Auth
+    | GetProfileBalance !Auth
 
 data UpdateCurrentProfileArgs = UpdateCurrentProfileArgs !Auth !ProfileBody
 
@@ -582,6 +600,10 @@ main = do
       withAuth auth $ \c authKey -> c.getCurrentProfile authKey
     CmdCurrentProfile (UpdateCurrentProfile (UpdateCurrentProfileArgs auth profileBody)) ->
       withAuth auth $ \c authKey -> c.updateCurrentProfile authKey profileBody
+    CmdCurrentProfile (GetProfileWalletAddress auth) ->
+      withAuth auth $ \c authKey -> c.getProfileWalletAddress authKey
+    CmdCurrentProfile (GetProfileBalance auth) ->
+      withAuth auth $ \c authKey -> c.getProfileBalance authKey
     CmdLogin loginBody -> do
       handle $ apiClient.login loginBody
     CmdServerTimestamp ->

dapps-certification-persistence/dapps-certification-persistence.cabal

@@ -22,5 +22,6 @@ library
                  , aeson
                  , swagger2
                  , lens
+                 , containers
     hs-source-dirs:   src
     default-language: Haskell2010

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

@@ -20,6 +20,8 @@ import IOHK.Certification.Persistence.Structure as X
   , TransactionEntry(..)
   , SubscriptionDTO(..)
   , TierDTO(..)
+  , ProfileWallet(..)
+  , WalletAddressStatus(..)
   )
 import Database.Selda as X
   ( fromId
@@ -37,7 +39,9 @@ import IOHK.Certification.Persistence.Structure.Subscription as X
   , TierId
   )
 import IOHK.Certification.Persistence.API as X
-  ( AdaUsdPrice
+  ( MinimalTransaction(..)
+  , MinimalTransactionEntry(..)
+  , AdaUsdPrice
   , upsertProfile
   , upsertTransaction
   , getProfile
@@ -59,7 +63,6 @@ import IOHK.Certification.Persistence.API as X
   , markAsReadyForCertification
   , getAllCertifiedRunsForAddress
   , getRunsToCertify
-  , getAllAmountsForAddress
   , getProfileBalance
   , addInitialData
   , getProfileSubscriptions
@@ -72,4 +75,8 @@ import IOHK.Certification.Persistence.API as X
   , getCurrentFeatures
   , getJWTSecret
   , insertJWTSecret
+  , getAllTransactions
+  , getProfileWallets
+  , getProfileWallet
+  , upsertProfileWallet
   )

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

@@ -19,9 +19,13 @@ import IOHK.Certification.Persistence.Structure.Run
 import IOHK.Certification.Persistence.Structure.Certification
 import IOHK.Certification.Persistence.Structure
 import Data.Time.Clock
+import Data.Fixed
 import Data.Int
+import Data.Bifunctor
 
-import Data.Fixed
+import Data.Functor
+
+import qualified Data.Map as Map
 
 getTransactionIdQ:: Text -> Query t (Col t (ID Transaction))
 getTransactionIdQ  externalAddress = do
@@ -137,14 +141,20 @@ getProfileBalance address = do
       -- get all paid subscriptions
       paidSubscriptions <- getAllPaidSubscriptions pid
       -- get all the amounts coming from this address
-      amountsFromAddress <- sum <$> getAllAmountsForAddress address
+      walletIncomingCredits <- getProfileWallet pid <&> getWalletCredits
       -- sum all the costs of the certified runs
       let certifiedCosts = sum $ map certificationPrice certifiedRuns
           -- calculate the amount of credits available for subscriptions
           subscriptionCredits = sum $ map subscriptionPrice paidSubscriptions
           -- calculate the amount of credits available
-          creditsAvailable = amountsFromAddress - certifiedCosts - subscriptionCredits
+          creditsAvailable = walletIncomingCredits - fromIntegral certifiedCosts - fromIntegral subscriptionCredits
       pure $ Just creditsAvailable
+  where
+  getWalletCredits :: Maybe (Profile, Maybe ProfileWallet) -> Int64
+  getWalletCredits Nothing = 0
+  getWalletCredits (Just (_, Nothing)) = 0
+  getWalletCredits (Just (_, Just ProfileWallet{..})) = profileWalletCredits
+
 
 upsertProfile :: (MonadSelda m, MonadMask m) => Profile -> Maybe DApp -> m (Maybe (ID Profile))
 upsertProfile profile@Profile{..} dappM = do
@@ -203,6 +213,39 @@ getProfileDAppQ pid = do
   restrict (dapp ! #dappId .== literal pid)
   pure dapp
 
+getProfileWalletQ :: ProfileId -> Query t (Row t Profile :*: Row t (Maybe ProfileWallet))
+getProfileWalletQ profileId = do
+  p <- select profiles
+  restrict (p ! #profileId .== literal profileId)
+  profileWallet <- leftJoin  (\pw -> pw ! #profileWalletId .== p ! #profileId) (select profileWallets)
+  pure (p :*: profileWallet)
+
+getProfileWallet :: MonadSelda f => ProfileId -> f (Maybe (Profile , Maybe ProfileWallet))
+getProfileWallet profileId = fmap toTuple . listToMaybe <$> query (getProfileWalletQ profileId)
+
+toTuple ::  a :*: b -> (a, b)
+toTuple (p :*: pw) = (p,pw)
+
+getProfileWalletsQ :: Query t (Row t Profile :*: Row t (Maybe ProfileWallet))
+getProfileWalletsQ = do
+  p <- select profiles
+  profileWallet <- leftJoin  (\pw -> pw ! #profileWalletId .== p ! #profileId) (select profileWallets)
+  pure (p :*: profileWallet)
+
+getProfileWallets :: MonadSelda m => m [(Profile, Maybe ProfileWallet)]
+getProfileWallets = map toTuple <$> query getProfileWalletsQ
+
+upsertProfileWallet :: (MonadSelda m,MonadMask m) => ProfileWallet -> m ()
+upsertProfileWallet ProfileWallet{..} = do
+  void $ upsert profileWallets
+    (\pw -> pw ! #profileWalletId .==  literal profileWalletId)
+    (`with`
+     [ #profileWalletAddress := text profileWalletAddress
+     , #profileWalletStatus := literal profileWalletStatus
+     , #profileWalletCredits := literal profileWalletCredits
+     ])
+    [ProfileWallet{..}]
+
 getProfile :: MonadSelda m => ID Profile -> m (Maybe ProfileDTO)
 getProfile pid = fmap (fmap toProfileDTO . listToMaybe ) $ query $ getProfileQ pid
 
@@ -249,14 +292,6 @@ getRunOwnerQ runId = do
     restrict (p ! #runId .== literal runId )
     pure (p ! #profileId)
 
-getAllAmountsForAddress :: MonadSelda m => Text -> m [Int64]
-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
 
@@ -515,6 +550,51 @@ getAllTiers = do
       , tierDtoTier = Tier{..}
       }
 
+type JustOutput = Bool
+
+
+data MinimalTransaction = MinimalTransaction
+                        { mtxTxId :: !(ID Transaction)
+                        , mtxAmount :: !Int64
+                        , mtxMetadata :: !Text
+                        }
+data MinimalTransactionEntry = MinimalTransactionEntry
+                        { mteId :: !(ID TransactionEntry)
+                        , mteAddress :: !Text
+                        , mteInput :: !Bool
+                        }
+
+getAllTransactions :: MonadSelda m => JustOutput -> m [(MinimalTransaction,[MinimalTransactionEntry])]
+getAllTransactions justOutput = do
+  tx <- query $ do
+    t <- select transactions
+    order (t ! #wtxTime) ascending
+    pure t
+  entries <- query $ do
+    e <- select transactionEntries
+    when justOutput $
+      restrict (e ! #txEntryInput .== literal justOutput)
+    pure e
+  -- make a map of entries by txId
+  let entriesMap = Map.fromListWith (<>) $ map (\e -> (txEntryTxId e, [e])) entries
+  -- link the entries to the transactions
+  let txs = map (\t -> (t, Map.findWithDefault [] (wtxId t) entriesMap)) tx
+  -- convert to the minimal representation
+  pure $ map (bimap toMinimalTransaction (map toMinimalTransactionEntry)) txs
+    where
+    toMinimalTransactionEntry :: TransactionEntry -> MinimalTransactionEntry
+    toMinimalTransactionEntry TransactionEntry{..} = MinimalTransactionEntry
+      { mteId = txEntryId
+      , mteAddress = txEntryAddress
+      , mteInput = txEntryInput
+      }
+    toMinimalTransaction :: Transaction -> MinimalTransaction
+    toMinimalTransaction Transaction{..} = MinimalTransaction
+      { mtxTxId = wtxId
+      , mtxAmount = wtxAmount
+      , mtxMetadata = wtxMetadata
+      }
+
 --TODO: replace this with a proper configuration
 withDb :: (MonadIO m, MonadMask m) => SeldaT SQLite m a -> m a
 withDb = withSQLite "certification.sqlite"

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

@@ -9,6 +9,7 @@
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE DerivingVia                #-}
+{-# LANGUAGE LambdaCase                 #-}
 
 {-# OPTIONS_GHC -Wno-ambiguous-fields #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -18,10 +19,14 @@ module IOHK.Certification.Persistence.Structure where
 import           Control.Lens         hiding (index, (.=))
 import           Data.Aeson
 import           Data.Proxy
---import           Control.Exception ( throw)
 import           Data.Swagger         hiding (Contact)
 import           Database.Selda
 import           Data.Int
+import           Database.Selda.SqlType as Selda
+import           Control.Exception ( throw)
+import           GHC.OverloadedLabels
+import           Data.Char as Char
+import           Data.Int (Int64)
 
 import           IOHK.Certification.Persistence.Structure.Profile
 import           IOHK.Certification.Persistence.Structure.Subscription
@@ -89,6 +94,57 @@ instance ToSchema TierDTO where
               & properties %~ (`mappend` [ ("features", featureSchema) ])
               & required %~  (<> [ "features" ])
 
+data WalletAddressStatus = Reserved | Overlapping
+  deriving (Generic, Show, Eq)
+
+instance FromJSON WalletAddressStatus where
+  parseJSON = withText "WalletAddressStatus" $ \case
+    "reserved" -> pure Reserved
+    "overlapping" -> pure Overlapping
+    _ -> fail "WalletAddressStatus must be one of: reserved, overlapping"
+
+instance ToJSON WalletAddressStatus where
+  toJSON = \case
+     Overlapping -> "overlapping"
+     Reserved -> "reserved"
+
+instance ToSchema WalletAddressStatus where
+  declareNamedSchema _ = do
+    let values = [ "reserved", "overlapping" ] :: [Value]
+    return $ NamedSchema (Just "WalletAddressStatus") $ mempty
+      & type_ ?~ SwaggerString
+      & enum_ ?~ values
+
+instance SqlType WalletAddressStatus where
+   mkLit n = LCustom TInt64 (LInt64 (toInt64 n))
+     where
+     toInt64 = \case
+       Overlapping -> 0
+       Reserved -> 1
+   sqlType _ = TInt64
+   fromSql (SqlInt64 0) = Overlapping
+   fromSql (SqlInt64 1) = Reserved
+   fromSql v            = throw $ userError $ "fromSql: expected SqlInt64, got " ++ show v
+   defaultValue = mkLit Overlapping
+
+data ProfileWallet = ProfileWallet
+  { profileWalletId :: ID Profile
+  , profileWalletAddress :: Text
+  , profileWalletStatus :: WalletAddressStatus
+  , profileWalletCredits :: Int64
+  } deriving (Generic, Show, Eq)
+
+instance SqlRow ProfileWallet
+
+instance ToJSON ProfileWallet where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = dropAndLowerFirst 14 }
+
+instance FromJSON ProfileWallet where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = dropAndLowerFirst 14 }
+
+instance ToSchema ProfileWallet where
+  declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { fieldLabelModifier = dropAndLowerFirst 14 }
+
 --------------------------------------------------------------------------------
 -- | Profile
 
@@ -220,10 +276,18 @@ transactions = table "transaction"
   ]
 
 transactionEntries :: Table TransactionEntry
-transactionEntries = table "entry"
+transactionEntries = table "transaction_entry"
   [ #txEntryId :- autoPrimary
   , #txEntryTxId :- foreignKey transactions #wtxId
   ]
+
+profileWallets :: Table ProfileWallet
+profileWallets = table "profile_wallet"
+  [ #profileWalletId :- primary
+  , #profileWalletId :- foreignKey profiles #profileId
+  ]
+
+
 dapps :: Table DApp
 dapps = table "dapp"
   [ #dappId :- unique
@@ -235,6 +299,7 @@ createTables = do
   createTable certifications
   createTable onChainCertifications
   createTable profiles
+  createTable profileWallets
   createTable dapps
   createTable runs
   createTable transactions

dapps-certification-persistence/src/IOHK/Certification/Persistence/example.json

@@ -0,0 +1,21 @@
+{
+  "0": {
+    "map": [
+      {
+        "k": {
+          "string": "payer"
+        },
+        "v": {
+          "list": [
+            {
+              "string":"addr_test1qphgqts20fhx0yx7ug42xehcnryukchy5k7hpaksgxax2fzt5w2gu3"
+            },
+            {
+              "string": "3s8wrw3c9tjs97dr5pulsvf39e56v7c9ar39asptcrtp"
+            }
+          ]
+        }
+      }
+    ]
+  }
+}

dapps-certification-signature-verification/src/IOHK/Certification/SignatureVerification.hs

@@ -8,6 +8,7 @@ module IOHK.Certification.SignatureVerification
   , COSESign1
   , encodeHex
   , decodeHex
+  , bech32AddressHash
   ) where
 
 import IOHK.Certification.SignatureVerification.CBOR as CBOR

plutus-certification.cabal

@@ -72,6 +72,7 @@ library
     Plutus.Certification.WalletClient
     Plutus.Certification.Synchronizer
     Plutus.Certification.Metadata
+    Plutus.Certification.ProfileWallet
   other-modules:
     Paths_plutus_certification
     Plutus.Certification.Metadata.Types
@@ -80,7 +81,7 @@ library
     Plutus.Certification.Web3StorageClient
     Plutus.Certification.Internal
     Plutus.Certification.WalletClient.Transaction
-    Plutus.Certification.TransactionBroadcaster
+    Plutus.Certification.CertificationBroadcaster
     Plutus.Certification.Server.Internal
     Plutus.Certification.Server.Instance
     Plutus.Certification.CoinGeckoClient