chore: generalize certification entity for multiple layers

decouple the direct realation between Run and Certification entities and introduce a one-to-one L1Certification entity

Author: bogdan-manole

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

@@ -4,6 +4,8 @@ import IOHK.Certification.Persistence.Structure as X
   , Status(..)
   , DApp(..)
   , Certification(..)
+  , L1Certification(..)
+  , L1CertificationDTO(..)
   , ProfileDTO(..)
   , runs
   , createTables
@@ -45,8 +47,8 @@ import IOHK.Certification.Persistence.API as X
   , getProfileAddress
   , syncRun
   , getRunOwner
-  , getCertification
-  , createCertificate
+  , getL1Certification
+  , createL1Certificate
   , deleteRun
   , markAsAborted
   , getRunStatus

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators       #-}
 {-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE NamedFieldPuns      #-}
 
 module IOHK.Certification.Persistence.API where
 
@@ -91,7 +92,6 @@ activateSubscription sub = do
         pure Nothing
     Nothing -> pure Nothing
 
-
 getAllCertifiedRunsForAddress :: MonadSelda m => Text -> m [Run]
 getAllCertifiedRunsForAddress address = query $ do
   -- get the profile id for the address
@@ -291,12 +291,12 @@ markAsReadyForCertification runId IpfsCid{..}  time = update runs
           , #reportContentId := literal (Just ipfsCid)
           ])
 
-createCertificate :: (MonadSelda m,MonadMask m)
+createL1Certificate :: (MonadSelda m,MonadMask m)
                   => UUID
                   -> TxId
                   -> UTCTime
-                  -> m (Maybe Certification)
-createCertificate runId TxId{..} time = transaction $ do
+                  -> m (Maybe L1CertificationDTO)
+createL1Certificate runId TxId{..} time = transaction $ do
   result <- query $ do
     run <- select runs
     restrict (run ! #runId .== literal runId)
@@ -309,19 +309,28 @@ createCertificate runId TxId{..} time = transaction $ do
         (`with` [ #runStatus := literal Certified
                 , #syncedAt := literal time
                 ])
-      let cert = Certification runId txId time
-      _ <- insert certifications [cert]
-      pure $ Just cert
+      let cert = Certification def txId time
+      certId <- insertWithPK certifications [cert]
+      -- and now add a l1Certification
+      let l1Cert = L1Certification runId certId
+      _ <-  insert l1Certifications [l1Cert]
+      pure $ Just (L1CertificationDTO l1Cert (cert { certId }))
     _ -> pure Nothing
 
-getCertificationQuery :: UUID -> Query t (Row t Certification)
-getCertificationQuery runID = do
-    c <- select certifications
-    restrict (c ! #certRunId .== literal runID )
-    pure c
+getL1CertificationQuery :: UUID -> Query t (Row t Certification :*: Row t L1Certification)
+getL1CertificationQuery runID = do
+    l1Cert <- select l1Certifications
+    restrict (l1Cert ! #l1CertRunId .== literal runID )
+    c <- innerJoin
+      (\t -> t ! #certId .== l1Cert ! #l1CertId)
+      (select certifications)
+    pure (c :*: l1Cert)
+
+getL1Certification :: MonadSelda m => UUID -> m (Maybe L1CertificationDTO)
+getL1Certification pid = fmap (fmap toL1CertificationDTO . listToMaybe ) $ query $ getL1CertificationQuery pid
 
-getCertification :: MonadSelda m => UUID -> m (Maybe Certification)
-getCertification = fmap listToMaybe . query . getCertificationQuery
+toL1CertificationDTO :: (Certification :*: L1Certification) -> L1CertificationDTO
+toL1CertificationDTO  (cert :*: l1Cert) = L1CertificationDTO l1Cert cert
 
 getRun :: MonadSelda m => UUID -> m (Maybe Run)
 getRun rid = listToMaybe <$> query (do

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

@@ -19,8 +19,10 @@ 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           Database.Selda.SqlType as Selda
 import           GHC.OverloadedLabels
 import           Data.Int
 
@@ -118,42 +120,116 @@ instance ToSchema ProfileDTO where
 
 --------------------------------------------------------------------------------
 -- | Certification
+{-
+data CertificationLevel = L0 | L1 | L2 | L3
+  deriving (Generic,Show,Read,Eq,Ord,Enum)
+
+instance SqlType CertificationLevel where
+  mkLit n = LCustom TInt64 (LInt64 (toInt64 n))
+    where
+    toInt64 = \case
+      L0 -> 0
+      L1 -> 1
+      L2 -> 2
+      L3 -> 3
+  sqlType _ = TInt64
+  fromSql (SqlInt64 0) = L0
+  fromSql (SqlInt64 1) = L1
+  fromSql (SqlInt64 2) = L2
+  fromSql (SqlInt64 3) = L3
+  fromSql v            = throw $ userError $ "fromSql: expected SqlInt64, got " ++ show v
+  defaultValue = mkLit L1
+
+instance ToJSON CertificationLevel where
+  toJSON = toJSON . \case
+    L0 -> "l0" :: String
+    L1 -> "l1"
+    L2 -> "l2"
+    L3 -> "l3"
+
+instance FromJSON CertificationLevel where
+  parseJSON = withText "CertificationLevel" $ \case
+    "l0" -> pure L0
+    "l1" -> pure L1
+    "l2" -> pure L2
+    "l3" -> pure L3
+    _    -> fail "CertificationLevel"
+
+instance ToSchema CertificationLevel where
+   declareNamedSchema _ = do
+     let values = [ "l0", "l1", "l2", "l3" ] :: [Value]
+     return $ NamedSchema (Just "CertificationLevel") $ mempty
+       & type_ ?~ SwaggerString
+       & enum_ ?~ values
+-}
 
 data Certification = Certification
-  { certRunId           :: UUID
+  { certId              :: ID Certification
   , certTransactionId   :: Text
   , certCreatedAt       :: UTCTime
   } deriving (Generic,Show)
 
 instance FromJSON Certification where
-    parseJSON = withObject "Certification" $ \v -> Certification
-      <$> v .: "runId"
-      <*> v .: "transactionId"
+    parseJSON = withObject "Certification" $ \v -> Certification def
+      <$> v .: "transactionId"
       <*> v .: "createdAt"
 
 instance ToJSON Certification where
   toJSON (Certification{..}) = object
       [ "transactionId" .= certTransactionId
       , "createdAt" .= certCreatedAt
-      , "runId" .= certRunId
       ]
 
 instance ToSchema Certification where
    declareNamedSchema _ = do
     textSchema <- declareSchemaRef (Proxy :: Proxy Text)
     utcSchema <- declareSchemaRef (Proxy :: Proxy UTCTime)
-    uuidSchema <- declareSchemaRef (Proxy :: Proxy UUID)
     return $ NamedSchema (Just "Certification") $ mempty
       & type_ ?~ SwaggerObject
       & properties .~
           [ ("transactionId", textSchema)
           , ("createdAt", utcSchema)
-          , ("runId", uuidSchema)
           ]
-      & required .~ [ "runId", "createdAt" ]
+      & required .~ [ "createdAt" ]
 
 instance SqlRow Certification
 
+-- one to one mapping with Run
+data L1Certification = L1Certification
+  { l1CertRunId :: UUID
+  , l1CertId  :: ID Certification
+  } deriving (Generic,Show)
+
+instance SqlRow L1Certification
+
+data L1CertificationDTO = L1CertificationDTO
+  { l1Certification :: L1Certification
+  , certification :: Certification
+  }
+
+instance ToJSON L1CertificationDTO where
+  toJSON L1CertificationDTO{..} = Object (x <> y)
+    where
+    x = case toJSON certification of
+            Object obj -> obj
+            _          -> KM.empty
+    y = KM.fromList [ "runId" .= l1CertRunId l1Certification ]
+
+instance FromJSON L1CertificationDTO where
+  parseJSON = withObject "L1CertificationDTO" $ \v -> do
+    l1Certification <- L1Certification
+      <$> v .: "runId"
+      <*> pure def
+    L1CertificationDTO l1Certification <$> v .: "runId"
+
+instance ToSchema L1CertificationDTO where
+  declareNamedSchema _ = do
+    certificationSchema <- declareSchema (Proxy :: Proxy Certification)
+    uuidSchema <- declareSchemaRef (Proxy :: Proxy UUID)
+    return $ NamedSchema (Just "TierDTO") $ certificationSchema
+              & properties %~ (`mappend` [ ("certRunId", uuidSchema) ])
+              & required %~  (<> [ "certRunId" ])
+
 --------------------------------------------------------------------------------
 -- | Dapp
 
@@ -199,7 +275,6 @@ instance ToJSON DApp where
 
 instance SqlRow DApp
 
-
 --------------------------------------------------------------------------------
 -- | Run
 
@@ -367,8 +442,14 @@ runs = table "run"
 
 certifications :: Table Certification
 certifications = table "certification"
-  [ #certRunId :- primary
-  , #certRunId :- foreignKey runs #runId
+  [ #certId :- primary
+  ]
+
+l1Certifications :: Table L1Certification
+l1Certifications = table "certification"
+  [ #l1CertRunId :- primary
+  , #l1CertRunId :- foreignKey runs #runId
+  , #l1CertId :- foreignKey certifications #certId
   ]
 
 dapps :: Table DApp
@@ -389,3 +470,4 @@ createTables = do
   createTable tiers
   createTable tierFeatures
   createTable subscriptions
+  createTable l1Certifications

src/Plutus/Certification/API/Routes.hs

@@ -126,7 +126,7 @@ type GetCertificateRoute = "run"
   :> Description "Get the L1 IPFS CID and the transaction id of the onchain stored Certificate"
   :> Capture "id" RunIDV1
   :> "certificate"
-  :> Get '[JSON] DB.Certification
+  :> Get '[JSON] DB.L1CertificationDTO
 
 type GetBalanceRoute (auth :: Symbol) = "profile"
   :> Description "Get the current balance of the profile"

src/Plutus/Certification/Server/Instance.hs

@@ -218,7 +218,7 @@ server ServerArgs{..} = NamedAPI
 
   , getCertification = \rid@RunID{..} -> withEvent eb GetCertification \ev -> do
     addField ev rid
-    DB.withDb (DB.getCertification uuid)
+    DB.withDb (DB.getL1Certification uuid)
       >>= maybeToServerError err404 "Certification not found"
 
   , getRepositoryInfo = \owner repo apiGhAccessTokenM -> withEvent eb GetRepoInfo \ev -> do

src/Plutus/Certification/Synchronizer.hs

@@ -176,7 +176,7 @@ monitorWalletTransactions eb args = withEvent eb MonitorTransactions $ \ev -> do
       return []
     handleResponse (Right transactions) = return transactions
 
-type CertificationProcess m = DB.ProfileId -> UUID -> m DB.Certification
+type CertificationProcess m = DB.ProfileId -> UUID -> m DB.L1CertificationDTO
 
 -- certify all runs who have enough credit to be certified
 -- and have not been certified yet
@@ -195,7 +195,7 @@ certifyRuns eb args = do
   -- TODO: parallelize this
   forM_ runsByProfile $ certifyProfileRuns certificationProcess
   where
-  certificationProcess a b = createCertification
+  certificationProcess a b = createL1Certification
     ( narrowEventBackend InjectTxBroadcaster eb ) args a (RunID b)
 
 activateSubscriptions :: (MonadIO m, MonadMask m,MonadError IOException m)

src/Plutus/Certification/TransactionBroadcaster.hs

@@ -12,7 +12,7 @@
 {-# LANGUAGE TypeFamilies #-}
 
 module Plutus.Certification.TransactionBroadcaster
-  ( createCertification
+  ( createL1Certification
   , renderTxBroadcasterSelector
   , TxBroadcasterSelector(..)
   ) where
@@ -52,13 +52,13 @@ renderTxBroadcasterSelector CreateCertification = ("create-certification", \case
   )
 
 -- caution: this function doesn't verify if the run has the proper status
-createCertification :: (MonadMask m,MonadIO m, MonadError IOException m)
-                    => EventBackend m r TxBroadcasterSelector
-                    -> WalletArgs
-                    -> DB.ProfileId
-                    -> RunIDV1
-                    -> m DB.Certification
-createCertification eb wargs profileId rid@RunID{..} = withEvent eb CreateCertification \ev -> do
+createL1Certification :: (MonadMask m,MonadIO m, MonadError IOException m)
+                      => EventBackend m r TxBroadcasterSelector
+                      -> WalletArgs
+                      -> DB.ProfileId
+                      -> RunIDV1
+                      -> m DB.L1CertificationDTO
+createL1Certification eb wargs profileId rid@RunID{..} = withEvent eb CreateCertification \ev -> do
   addField ev (CreateCertificationRunID rid)
 
   -- getting required profile information before further processing
@@ -74,13 +74,13 @@ createCertification eb wargs profileId rid@RunID{..} = withEvent eb CreateCertif
   let certificate = Wallet.CertificationMetadata uuid (DB.IpfsCid ipfsCid) dappName websiteUrl
                     (profile.twitter) uri dappVersion
 
-  -- broadcast the certification
+  -- broadcast the l1 certification
   tx@Wallet.TxResponse{..} <- Wallet.broadcastTransaction wargs 1304 certificate
     >>= eitherToError show
   addField ev (CreateCertificationTxResponse tx)
 
   -- persist it into the db
-  (DB.withDb . DB.createCertificate uuid txRespId =<< getNow)
+  (DB.withDb . DB.createL1Certificate uuid txRespId =<< getNow)
     >>= maybeToError "Certification couldn't be persisted"
   where
     getRun = DB.withDb (DB.getRun uuid) >>= maybeToError "No Run"