temp commit

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

@@ -45,9 +45,9 @@ import IOHK.Certification.Persistence.API as X
   , markAsReadyForCertification
   , getAllCertifiedRunsForAddress
   , getRunsToCertify
-  , getAllAmountsForAddress
   , getProfileBalance
   , getAllTransactions
   , getProfileWallets
+  , getProfileWallet
   , upsertProfileWallet
   )

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

@@ -14,8 +14,9 @@ import           IOHK.Certification.Persistence.Structure
 import           Data.Int
 import           Data.Bifunctor
 
-import qualified Data.Map as Map
+import           Data.Functor
 
+import qualified Data.Map as Map
 
 getTransactionIdQ:: Text -> Query t (Col t (ID Transaction))
 getTransactionIdQ  externalAddress = do
@@ -79,16 +80,22 @@ getProfileBalance address = do
   profileIdM <- getProfileId address
   case profileIdM of
     Nothing -> pure Nothing
-    Just _ -> do
+    Just pid -> do
       -- get all certified runs
       certifiedRuns <- getAllCertifiedRunsForAddress address
       -- 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
-          creditsAvailable = amountsFromAddress - fromIntegral certifiedCosts
+          creditsAvailable = walletIncomingCredits - fromIntegral certifiedCosts
       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
@@ -147,17 +154,27 @@ 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 = toTuple <$> query getProfileWalletsQ
-  where
-  toTuple ::  [Profile :*: Maybe ProfileWallet] -> [(Profile, Maybe ProfileWallet)]
-  toTuple = map (\(p :*: pw) -> (p,pw))
+getProfileWallets = map toTuple <$> query getProfileWalletsQ
 
 upsertProfileWallet :: (MonadSelda m,MonadMask m) => ProfileWallet -> m ()
 upsertProfileWallet ProfileWallet{..} = do
@@ -216,14 +233,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
 

server/Main.hs

@@ -59,6 +59,7 @@ import IOHK.Certification.Actions
 import Plutus.Certification.JWT
 import Data.Int
 import IOHK.Certification.Persistence (toId)
+import Plutus.Certification.ProfileWallet
 import Paths_plutus_certification qualified as Package
 import IOHK.Certification.Persistence qualified as DB
 import Data.HashSet as HashSet
@@ -357,17 +358,20 @@ main = do
       -- get the whitelisted addresses from $WLIST env var
       -- if useWhitelist is set to false the whitelist is ignored
       whitelist <- if not args.useWhitelist then pure Nothing else Just <$> whitelisted
+      addressRotation <- liftIO $ newMVar emptyAddressRotation
       _ <- initDb
       _ <- forkIO $ startTransactionsMonitor (narrowEventBackend InjectSynchronizer eb) (args.wallet) 10
       -- TODO: this has to be refactored
       runSettings settings . application (narrowEventBackend InjectServeRequest eb) $
         cors (const $ Just corsPolicy) .
         serveWithContext (Proxy @APIWithSwagger) (genAuthServerContext whitelist args.auth) .
-        (\r -> swaggerSchemaUIServer (documentation args.auth) :<|> server (serverArgs args caps r eb whitelist))
+        (\r -> swaggerSchemaUIServer (documentation args.auth)
+          :<|> server (serverArgs args caps r eb whitelist addressRotation))
   exitFailure
   where
   serverArgs args caps r eb = ServerArgs
     caps (args.wallet) args.githubToken (jwtArgs args.auth) (be r eb) (args.signatureTimeout)
+
   jwtArgs PlainAddressAuth = Nothing
   jwtArgs (JWTAuth args) = Just args
   documentation PlainAddressAuth = swaggerJson

src/Plutus/Certification/API/Routes.hs

@@ -137,6 +137,13 @@ type WalletAddressRoute = "wallet-address"
   :> Description "Get the wallet address the backend operates with"
   :> Get '[JSON] WalletAddress
 
+type GetProfileWalletAddressRoute (auth :: Symbol) = "profile"
+  :> Description "Get the wallet address of the profile"
+  :> "current"
+  :> "wallet-address"
+  :> AuthProtect auth
+  :> Get '[JSON] (Maybe (DB.WalletAddressStatus,WalletAddress))
+
 type GitHubRoute = "repo"
   :> Description "Get the github repo information"
   :> Capture "owner" Text
@@ -231,6 +238,7 @@ data NamedAPI (auth :: Symbol) mode = NamedAPI
   , updateCurrentProfile :: mode :- UpdateCurrentProfileRoute auth
   , createCertification :: mode :- CreateCertificationRoute auth
   , getCertification :: mode :- GetCertificateRoute
+  , getProfileWalletAddress :: mode :- GetProfileWalletAddressRoute auth
   , walletAddress :: mode :- WalletAddressRoute
   , getProfileBalance :: mode :- GetBalanceRoute auth
   , getRunDetails :: mode :- GetRunDetailsRoute

src/Plutus/Certification/API/Swagger.hs

@@ -40,6 +40,7 @@ type UnnamedApi (auth :: Symbol)
   :<|> GetBalanceRoute auth
   :<|> WalletAddressRoute
   :<|> GitHubRoute
+  :<|> GetProfileWalletAddressRoute auth
 
 type UnnamedApiWithLogin (auth :: Symbol)
      = UnnamedApi auth

src/Plutus/Certification/ProfileWallet.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE TupleSections        #-}
 {-# LANGUAGE GADTs                #-}
 {-# LANGUAGE BlockArguments       #-}
 {-# LANGUAGE LambdaCase           #-}
@@ -9,13 +10,22 @@
 module Plutus.Certification.ProfileWallet
   ( resyncWallets
   , renderProfileWalletSyncSelector
+  , ProfileWalletSyncSelector
+  , PrevAssignments
+  , AddressReservation(..)
+  , getTemporarilyWalletAddress
+  , AddressRotation(..)
+  , emptyAddressRotation
+  , WalletAddress(..)
+  , ProfileAddress(..)
   ) where
 
 import Prelude as P
 
 import Servant.Client.Core
 import Data.Aeson
 import Data.Aeson.Types
+import Data.List
 import Control.Monad as M
 import Control.Lens.Internal.CTypes (Word64)
 import Data.Text (Text)
@@ -30,6 +40,7 @@ import Plutus.Certification.WalletClient (WalletArgs)
 import Data.Either
 import Observe.Event.Render.JSON
 import Observe.Event
+import Data.Function
 
 import qualified Plutus.Certification.WalletClient as Wallet
 import qualified IOHK.Certification.Persistence as DB
@@ -41,7 +52,6 @@ import qualified Data.Map as Map
 --------------------------------------------------------------------------------
 -- | Basic types for the profile wallet
 
-
 newtype WalletAddress = WalletAddress { unWalletAddress :: Text }
                       deriving (Eq,Show,Ord)
 
@@ -136,12 +146,14 @@ parseMetaData label keyName = withObject label $ \o -> do
 --------------------------------------------------------------------------------
 -- | Events
 
-data ResyncWalletsArgs = TransactionMappingErrors [String]
-                       | ExtraMoney ExtraMoney
+data ResyncWalletsArgs = TransactionMappingErrors !Int
+                       | ExtraMoney !ExtraMoney
+                       | TransactionMappingCounts !(Int,Int,Int)
+
 data AssignAddressArgs
-  = AssignAddressInputs (ProfileAddress, WalletAddress, OverlappingAddress)
-  | AssignAddressError String
-  | AssignAddressTxResp Wallet.TxResponse
+  = AssignAddressInputs !(ProfileAddress, WalletAddress, OverlappingAddress)
+  | AssignAddressError !String
+  | AssignAddressTxResp !Wallet.TxResponse
 
 data ProfileWalletSyncSelector f where
   ResyncWallets :: ProfileWalletSyncSelector ResyncWalletsArgs
@@ -156,6 +168,13 @@ renderProfileWalletSyncSelector ResyncWallets =
   ("resync-wallets", \case
     TransactionMappingErrors errors -> ("transaction-mapping-errors", toJSON errors)
     ExtraMoney extraMoney -> ("extra-money", toJSON extraMoney)
+    TransactionMappingCounts (simple,designated,assignments) ->
+      ("transaction-mapping-count", toJSON [aesonQQ|
+          { "simplePayments" : #{simple}
+          , "designatedPayments" : #{designated}
+          , "addressAssignments" : #{assignments}
+          } |]
+      )
   )
 renderProfileWalletSyncSelector AssignAddress = ("assign-address", \case
   AssignAddressInputs (ProfileAddress{..}, WalletAddress{..}, overlappingAddress) ->
@@ -188,7 +207,8 @@ resyncWallets eb wargs prevAssignments = withEvent eb ResyncWallets \ev -> do
   -- fetch the db transactions and create wallets
   (errors,trans) <- DB.withDb ( DB.getAllTransactions False )
     <&> (lefts &&& rights) . fmap fromDbTransaction'
-  addField ev $ TransactionMappingErrors errors
+  addField ev $ TransactionMappingErrors (length errors)
+  addField ev $ TransactionMappingCounts (countTransactions trans)
 
   let (profileWallets,extraMoney) = createProfileWallets trans
   addField ev $ ExtraMoney extraMoney
@@ -204,7 +224,11 @@ resyncWallets eb wargs prevAssignments = withEvent eb ResyncWallets \ev -> do
   mainHash = hash wargs.walletAddress
   hash = Sig.bech32AddressHash . Sig.Bech32Address
   isOurAddress = (== mainHash) . hash
-
+  countTransactions = foldl' (\(a,b,c) -> \case
+    SimplePayment{} -> (a+1,b,c)
+    DesignatedPayment{} -> (a,b+1,c)
+    WalletAddressAssignment{} -> (a,b,c+1)
+    ) (0,0,0)
 --------------------------------------------------------------------------------
 -- | ADDRESS ASSIGNMENT DISSEMINATION
 
@@ -394,6 +418,49 @@ syncDbProfileWallets eb wallets = do
           Overlapping -> DB.Overlapping
       }
 --------------------------------------------------------------------------------
+-- | ADDRESS ROTATION
+
+data AddressRotation = AddressRotation
+  { byAddress :: Map WalletAddress [DB.ProfileId]
+  , byProfile :: Map DB.ProfileId WalletAddress
+  } deriving (Show,Eq)
+
+emptyAddressRotation :: AddressRotation
+emptyAddressRotation = AddressRotation
+  { byAddress = Map.empty
+  , byProfile = Map.empty
+  }
+
+getTemporarilyWalletAddress :: [WalletAddress]
+                            -> DB.ProfileId
+                            -> AddressRotation
+                            ->  (Maybe WalletAddress,AddressRotation)
+getTemporarilyWalletAddress addresses profileId rotation =
+  case (profileAddress,nextAddress) of
+    (Just address,_) -> (Just address,rotation)
+    (Nothing,Just address) -> (Just address,AddressRotation
+      { byAddress = Map.insertWith (++) address [profileId] (byAddress rotation)
+      , byProfile = Map.insert profileId address (byProfile rotation)
+      })
+    (Nothing,Nothing) -> (Nothing,rotation)
+
+  where
+  nextAddress :: Maybe WalletAddress
+  nextAddress = case sortedAddress of
+    [] -> Nothing
+    ((address,_):_) -> Just address
+
+  profileAddress :: Maybe WalletAddress
+  profileAddress = Map.lookup profileId (byProfile rotation)
+
+  sortedAddress :: [(WalletAddress,Int)]
+  sortedAddress  = sortBy (compare `on` snd) $
+    map (\address -> (address,Map.findWithDefault 0 address byAddressWithWeight)) addresses
+
+  byAddressWithWeight :: Map WalletAddress Int
+  byAddressWithWeight = Map.fromListWith (+) (map (second length) (Map.toList (byAddress rotation)))
+
+--------------------------------------------------------------------------------
 -- | ProfileWallets related functions
 
 createProfileWallets :: [Transaction] -> (ProfileWallets,ExtraMoney)