Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

feat: auditor certificates (PLT-5768) #74

Merged
merged 3 commits into from
Jul 26, 2023
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions .gitignore
Original file line number Diff line number Diff line change
Expand Up @@ -14,3 +14,4 @@ Makefile
*.sqlite
react-web/node_modules/
*.ignore.*
todo.txt
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,8 @@ library
other-modules: IOHK.Certification.Persistence.Structure
, IOHK.Certification.Persistence.API
, IOHK.Certification.Persistence.Structure.Subscription
, IOHK.Certification.Persistence.Structure.Certification
, IOHK.Certification.Persistence.Structure.Run
, IOHK.Certification.Persistence.Structure.Profile
build-depends: base
, selda
Expand Down
Original file line number Diff line number Diff line change
@@ -1,11 +1,17 @@
module IOHK.Certification.Persistence (module X) where
import IOHK.Certification.Persistence.Structure as X
import IOHK.Certification.Persistence.Structure.Run as X
( Run(..)
, Status(..)
, DApp(..)
, Certification(..)
)
import IOHK.Certification.Persistence.Structure.Certification as X
( Certification(..)
, L1Certification(..)
, CertificationLevel(..)
, L1CertificationDTO(..)
)
import IOHK.Certification.Persistence.Structure as X
( DApp(..)
, ProfileDTO(..)
, runs
, createTables
, IpfsCid(..)
, TxId(..)
Expand Down Expand Up @@ -45,8 +51,8 @@ import IOHK.Certification.Persistence.API as X
, getProfileAddress
, syncRun
, getRunOwner
, getCertification
, createCertificate
, getL1Certification
, createL1Certificate
, deleteRun
, markAsAborted
, getRunStatus
Expand Down
Original file line number Diff line number Diff line change
@@ -1,9 +1,10 @@
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE DuplicateRecordFields #-}

module IOHK.Certification.Persistence.API where

Expand All @@ -14,6 +15,8 @@ import Database.Selda
import Database.Selda.SQLite
import IOHK.Certification.Persistence.Structure.Profile
import IOHK.Certification.Persistence.Structure.Subscription as Subscription
import IOHK.Certification.Persistence.Structure.Run
import IOHK.Certification.Persistence.Structure.Certification
import IOHK.Certification.Persistence.Structure
import Data.Time.Clock
import Data.Int
Expand Down Expand Up @@ -91,7 +94,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
Expand Down Expand Up @@ -291,12 +293,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)
Expand All @@ -309,19 +311,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 (#certId certId cert))
_ -> 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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedLists #-}
Expand All @@ -19,13 +18,15 @@ 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 GHC.OverloadedLabels
import Data.Int

import IOHK.Certification.Persistence.Structure.Profile
import IOHK.Certification.Persistence.Structure.Subscription
import IOHK.Certification.Persistence.Structure.Certification
import IOHK.Certification.Persistence.Structure.Run

import qualified Data.Text as Text
import qualified Data.Aeson.KeyMap as KM
Expand Down Expand Up @@ -116,44 +117,6 @@ instance ToSchema ProfileDTO where
return $ NamedSchema (Just "ProfileDTO") $ profileSchema
& properties %~ (`mappend` [ ("dapp", dappSchema) ])

--------------------------------------------------------------------------------
-- | Certification

data Certification = Certification
{ certRunId :: UUID
, certTransactionId :: Text
, certCreatedAt :: UTCTime
} deriving (Generic,Show)

instance FromJSON Certification where
parseJSON = withObject "Certification" $ \v -> Certification
<$> v .: "runId"
<*> 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" ]

instance SqlRow Certification

--------------------------------------------------------------------------------
-- | Dapp

Expand Down Expand Up @@ -199,116 +162,6 @@ instance ToJSON DApp where

instance SqlRow DApp


--------------------------------------------------------------------------------
-- | Run

data Status = Queued | Failed | Succeeded | ReadyForCertification | Certified | Aborted
deriving (Show, Read, Bounded, Enum, Eq, Generic)

instance ToJSON Status where
toJSON :: Status -> Value
toJSON Queued = toJSON ("queued" :: Text)
toJSON Failed = toJSON ("failed" :: Text)
toJSON Succeeded = toJSON ("succeeded" :: Text)
toJSON ReadyForCertification = toJSON ("ready-for-certification" :: Text)
toJSON Certified = toJSON ("certified" :: Text)
toJSON Aborted = toJSON ("aborted" :: Text)

instance FromJSON Status where
parseJSON =
withText "Status" handle
where
handle "queued" = pure Queued
handle "failed" = pure Failed
handle "succeeded" = pure Succeeded
handle "certified" = pure Succeeded
handle "ready-for-certification" = pure ReadyForCertification
handle "aborted" = pure Aborted
handle t = fail $ "provided text (" ++ show t ++ ") is not a Status"

instance SqlType Status

type CommitHash = Text
type CertificationPrice = Int64
data Run = Run
{ runId :: UUID
, created :: UTCTime
, finishedAt :: Maybe UTCTime
, syncedAt :: UTCTime
, repoUrl :: Text
, commitDate :: UTCTime
, commitHash :: CommitHash
, runStatus :: Status
, profileId :: ID Profile
, certificationPrice :: CertificationPrice
, reportContentId :: Maybe Text
} deriving (Generic,Show)

instance ToSchema Status where
declareNamedSchema _ = do
let values = ["queued", "failed", "succeeded", "certified", "ready-for-certification","aborted"] :: [Value]
return $ NamedSchema (Just "RunStatus") $ mempty
& type_ ?~ SwaggerString
& enum_ ?~ values

instance ToSchema Run where
declareNamedSchema _ = do
utcSchema <- declareSchemaRef (Proxy :: Proxy UTCTime)
utcSchemaM <- declareSchemaRef (Proxy :: Proxy (Maybe UTCTime))
textSchema <- declareSchemaRef (Proxy :: Proxy Text)
statusSchema <- declareSchemaRef (Proxy :: Proxy Status)
uuidSchema <- declareSchemaRef (Proxy :: Proxy UUID)
intSchema <- declareSchemaRef (Proxy :: Proxy Int)
return $ NamedSchema (Just "Run") $ mempty
& type_ ?~ SwaggerObject
& properties .~
[ ("created", utcSchema)
, ("runId", uuidSchema)
, ("finishedAt", utcSchemaM)
, ("syncedAt", utcSchema)
, ("repoUrl", textSchema)
, ("commitDate", utcSchema)
, ("commitHash", textSchema)
, ("runStatus", statusSchema)
, ("certificationPrice", intSchema)
, ("reportContentId", textSchema)
]
& required .~ [ "runId", "created", "utcSchema", "repoUrl"
, "commitDate","commitHash", "runStatus", "certificationPrice"]

instance ToJSON Run where
toJSON (Run{..}) = object
[ "runId" .= runId
, "created" .= created
, "finishedAt" .= finishedAt
, "syncedAt" .= syncedAt
, "repoUrl" .= repoUrl
, "commitDate" .= commitDate
, "commitHash" .= commitHash
, "runStatus" .= runStatus
, "certificationPrice" .= certificationPrice
, "reportContentId" .= reportContentId
]

instance FromJSON Run where
parseJSON = withObject "Run" $ \v -> Run
<$> v .: "runId"
<*> v .: "created"
<*> v .:? "finishedAt" .!= Nothing
<*> v .: "syncedAt"
<*> v .: "repoUrl"
<*> v .: "commitDate"
<*> v .: "commitHash"
<*> v .: "runStatus"
<*> pure def
<*> v .: "certificationPrice"
<*> v .:? "reportContentId" .!= Nothing

instance SqlRow Run
instance IsLabel "profileId" (ID Profile -> Profile -> Profile) where
fromLabel v p = p { profileId = v}

--------------------------------------------------------------------------------
-- | Wallet transactions

Expand Down Expand Up @@ -358,19 +211,6 @@ transactionEntries = table "entry"
[ #txEntryId :- autoPrimary
, #txEntryTxId :- foreignKey transactions #wtxId
]
runs :: Table Run
runs = table "run"
[ #runId :- primary
, #profileId :- foreignKey profiles #profileId
, #created :- index
]

certifications :: Table Certification
certifications = table "certification"
[ #certRunId :- primary
, #certRunId :- foreignKey runs #runId
]

dapps :: Table DApp
dapps = table "dapp"
[ #dappId :- unique
Expand All @@ -380,6 +220,7 @@ dapps = table "dapp"
createTables :: MonadSelda m => m ()
createTables = do
createTable certifications
createTable onChainCertifications
createTable profiles
createTable dapps
createTable runs
Expand All @@ -389,3 +230,4 @@ createTables = do
createTable tiers
createTable tierFeatures
createTable subscriptions
createTable l1Certifications
Loading
Loading