From ebddeb3e314c2341753071129688e4ef68e1255f Mon Sep 17 00:00:00 2001 From: Bogdan Manole Date: Tue, 29 Aug 2023 16:46:34 +0300 Subject: [PATCH] feat: format Test-Runs certificate compliant with CIP-0096 ( PLT-6087) --- client/Main.hs | 90 +++++++++++++++++-- .../Persistence/Structure/Run.hs | 2 +- src/Plutus/Certification/API/Routes.hs | 17 ++-- src/Plutus/Certification/API/Swagger.hs | 3 +- src/Plutus/Certification/Metadata.hs | 34 ++++--- src/Plutus/Certification/Metadata/Types.hs | 39 ++++++-- src/Plutus/Certification/Server/Instance.hs | 62 ++++++++----- src/Plutus/Certification/Server/Internal.hs | 18 ++-- src/Plutus/Certification/Synchronizer.hs | 4 +- 9 files changed, 197 insertions(+), 72 deletions(-) diff --git a/client/Main.hs b/client/Main.hs index b3bb65e5..f6547fd4 100644 --- a/client/Main.hs +++ b/client/Main.hs @@ -32,6 +32,7 @@ import Text.Regex import Data.Int import qualified Data.ByteString.Base16 as Hexa +import Plutus.Certification.Metadata newtype PublicKey = PublicKey { unPublicKey :: ByteString } @@ -172,6 +173,81 @@ createCertificationParser :: Parser CreateCertificationArgs createCertificationParser = CreateCertificationArgs <$> getRunParser <*> authParser + <*> certificationInputParser + -- dry-run + <*> optional (switch + ( long "dry-run" + <> help "dry run" + )) + +certificationIssuerParser :: Parser CertificateIssuer +certificationIssuerParser = CertificateIssuer + -- name + <$> option str + ( long "issuer-name" + <> metavar "ISSUER-NAME" + <> help "issuer name" + ) + -- URL + <*> optional ( URL <$> option str + ( long "issuer-url" + <> metavar "ISSUER-URL" + <> help "issuer URL" + )) + <*> parseSocial + +parseSocial :: Parser Social +parseSocial = Social + <$> optional ( option str + ( long "twitter" + <> metavar "TWITTER" + <> help "twitter handle" + )) + <*> optional ( option str + ( long "github" + <> metavar "GITHUB" + <> help "github handle" + )) + <*> option str + ( long "contact" + <> metavar "CONTACT" + <> help "contact email" + ) + <*> option str + ( long "website" + <> metavar "WEBSITE" + <> help "website URL" + ) + <*> optional ( option str + ( long "discord" + <> metavar "DISCORD" + <> help "discord handle" + )) + +certificationInputParser :: Parser CertificationInput +certificationInputParser = CertificationInput + <$> (Subject <$> option str + ( long "subject" + <> metavar "SUBJECT" + <> help "dapp subject" + )) + <*> certificationIssuerParser + <*> option str + ( long "summary" + <> metavar "SUMMARY" + <> help "dapp summary" + ) + -- disclaimer optional + <*> option str + ( long "disclaimer" + <> metavar "DISCLAIMER" + <> help "dapp disclaimer" + <> value Text.empty + ) + -- TODO: add scripts + <*> pure [] + + data RunCommand = Create !CreateRunArgs @@ -179,7 +255,6 @@ data RunCommand | Abort !AbortRunArgs | GetLogs !GetLogsArgs | GetRuns !GetRunsArgs - | GetCertification !RunIDV1 | CreateCertification !CreateCertificationArgs runCommandParser :: Parser RunCommand @@ -189,8 +264,7 @@ runCommandParser = hsubparser <> command "abort" (Abort <$> abortRunInfo) <> command "get-logs" (GetLogs <$> getLogsInfo) <> command "get-many" (GetRuns <$> getRunsInfo) - <> command "get-certification" (GetCertification <$> getCertificationInfo) - <> command "create-certification" (CreateCertification <$> createCertificationInfo) + <> command "create-l1-certification" (CreateCertification <$> createCertificationInfo) ) data CreateRunArgs = CreateRunArgs !CommitOrBranch !Auth @@ -199,7 +273,8 @@ data GetRunsArgs = GetRunsArgs !Auth !(Maybe UTCTime) !(Maybe Int) type DeleteRun = Maybe Bool data AbortRunArgs = AbortRunArgs !RunIDV1 !Auth !DeleteRun -data CreateCertificationArgs= CreateCertificationArgs !RunIDV1 !Auth +type DryRun = Maybe Bool +data CreateCertificationArgs= CreateCertificationArgs !RunIDV1 !Auth !CertificationInput !DryRun data GetLogsArgs = GetLogsArgs { runId :: !RunIDV1 @@ -590,12 +665,11 @@ main = do handle $ apiClient.getLogs ref zt act CmdRun (GetRuns (GetRunsArgs pubKey after' count')) -> withAuth pubKey $ \c authKey -> c.getRuns authKey after' count' - CmdRun (GetCertification ref) -> - handle $ apiClient.getCertification ref CmdGetRepositoryInfo (GetGitHubAddressArgs owner' repo' gitHubAccessToken') -> handle $ apiClient.getRepositoryInfo owner' repo' gitHubAccessToken' - CmdRun (CreateCertification (CreateCertificationArgs ref auth)) -> - withAuth auth $ \c authKey -> True <$ c.createCertification authKey ref + CmdRun (CreateCertification (CreateCertificationArgs ref auth certInput dryRun)) -> + withAuth auth $ \c authKey -> + c.createCertification authKey ref certInput dryRun CmdCurrentProfile (GetCurrentProfile auth) -> withAuth auth $ \c authKey -> c.getCurrentProfile authKey CmdCurrentProfile (UpdateCurrentProfile (UpdateCurrentProfileArgs auth profileBody)) -> diff --git a/dapps-certification-persistence/src/IOHK/Certification/Persistence/Structure/Run.hs b/dapps-certification-persistence/src/IOHK/Certification/Persistence/Structure/Run.hs index 30797030..edb86152 100644 --- a/dapps-certification-persistence/src/IOHK/Certification/Persistence/Structure/Run.hs +++ b/dapps-certification-persistence/src/IOHK/Certification/Persistence/Structure/Run.hs @@ -76,7 +76,7 @@ data Run = Run , runStatus :: Status , profileId :: ID Profile , certificationPrice :: CertificationPrice - , reportContentId :: Maybe Text + , reportContentId :: Maybe Text } deriving (Generic,Show) instance ToSchema Status where diff --git a/src/Plutus/Certification/API/Routes.hs b/src/Plutus/Certification/API/Routes.hs index c7fd5fe8..d931b6d0 100644 --- a/src/Plutus/Certification/API/Routes.hs +++ b/src/Plutus/Certification/API/Routes.hs @@ -115,18 +115,14 @@ type UpdateCurrentProfileRoute (auth :: Symbol) = "profile" :> ReqBody '[JSON] ProfileBody :> Put '[JSON] DB.ProfileDTO -type CreateCertificationRoute (auth :: Symbol) = "run" +type CreateL1CertificationRoute (auth :: Symbol) = "run" :> Description "Store the L1 Report into IPFS and broadcasts the Certificate onchain" :> AuthProtect auth :> Capture "id" RunIDV1 :> "certificate" - :> PostNoContent - -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.L1CertificationDTO + :> ReqBody '[JSON] CertificationInput + :> QueryParam "dry-run" Bool + :> Post '[JSON] Metadata.FullMetadata type GetBalanceRoute (auth :: Symbol) = "profile" :> Description "Get the current balance of the profile" @@ -212,7 +208,7 @@ type GetAdaUsdPriceRoute = "ada-usd-price" :> Get '[JSON] DB.AdaUsdPrice type CreateAuditorReport (auth :: Symbol) = "auditor" - :> Description "Get the available tiers" + :> Description "Get the L2 report" :> "reports" :> QueryParam "dry-run" Bool :> ReqBody '[JSON] Metadata.AuditorCertificationInput @@ -301,9 +297,8 @@ data NamedAPI (auth :: Symbol) mode = NamedAPI , getRuns :: mode :- GetRunsRoute auth , getCurrentProfile :: mode :- GetCurrentProfileRoute auth , updateCurrentProfile :: mode :- UpdateCurrentProfileRoute auth - , createCertification :: mode :- CreateCertificationRoute auth - , getCertification :: mode :- GetCertificateRoute , getProfileWalletAddress :: mode :- GetProfileWalletAddressRoute auth + , createCertification :: mode :- CreateL1CertificationRoute auth , walletAddress :: mode :- WalletAddressRoute , getProfileBalance :: mode :- GetBalanceRoute auth , getRunDetails :: mode :- GetRunDetailsRoute diff --git a/src/Plutus/Certification/API/Swagger.hs b/src/Plutus/Certification/API/Swagger.hs index 46093ec0..df372b1e 100644 --- a/src/Plutus/Certification/API/Swagger.hs +++ b/src/Plutus/Certification/API/Swagger.hs @@ -37,8 +37,7 @@ type UnnamedApi (auth :: Symbol) :<|> GetRunDetailsRoute :<|> GetCurrentProfileRoute auth :<|> UpdateCurrentProfileRoute auth - :<|> CreateCertificationRoute auth - :<|> GetCertificateRoute + :<|> CreateL1CertificationRoute auth :<|> GetBalanceRoute auth :<|> WalletAddressRoute :<|> GitHubRoute diff --git a/src/Plutus/Certification/Metadata.hs b/src/Plutus/Certification/Metadata.hs index d4f6dd5e..cff36de9 100644 --- a/src/Plutus/Certification/Metadata.hs +++ b/src/Plutus/Certification/Metadata.hs @@ -14,6 +14,10 @@ module Plutus.Certification.Metadata , createDraftMetadata , createMetadataAndPushToIpfs , FullMetadata(..) +, parseURIUnsafe +, CertificationInput(..) +, AuditorCertificationInput(..) +, URL(..) ) where import Plutus.Certification.Metadata.Types as X @@ -77,22 +81,26 @@ user error (Report URLs do not match) Report {reportURLs = [ReportURL {unReportURL = ipfs://bafkreihic53arwawc73rivbnxl3ax2cc26xvd23x67obm5vq33uosdwbcy},ReportURL {unReportURL = https://bafkreihic53arwawc73rivbnxl3ax2cc26xvd23x67obm5vq33uosdwbcy.ipfs.w3s.link}], reportHash = "64663839663138363636393838333631346534613932333265346235643236376337396531346435316266643836383263616661623536396663376433313463"} -} -certLevel :: DB.CertificationLevel -certLevel = DB.L2 +--certLevel :: DB.CertificationLevel +--certLevel = DB.L2 createOffchainMetadata :: (MonadIO m) => AuditorCertificationInput + -> DB.CertificationLevel -> m OffChainMetadata -createOffchainMetadata AuditorCertificationInput{..} = do +createOffchainMetadata AuditorCertificationInput{..} certLevel = do + let CertificationInput{..} = certificationInput report' <- toReport report let certificationLevel = certLevel pure OffChainMetadata { report = report', ..} createOnchainMetadata :: AuditorCertificationInput -> Maybe (OffChainMetadata,[MetadataUrl]) + -> DB.CertificationLevel -> OnChainMetadata -createOnchainMetadata AuditorCertificationInput{..} offchainM = - let (rootHash,metadata') = case offchainM of +createOnchainMetadata AuditorCertificationInput{..} offchainM certLevel = + let CertificationInput{..} = certificationInput + (rootHash,metadata') = case offchainM of Nothing -> (Hash "",[]) Just (offchain,metadata) -> -- hash represents the encoded json of the offchain metadata @@ -137,20 +145,24 @@ instance ToSchema FullMetadata where createDraftMetadata :: MonadIO m => AuditorCertificationInput + -> DB.CertificationLevel -> m FullMetadata -createDraftMetadata input = do - offchain <- createOffchainMetadata input - let onchain = createOnchainMetadata input Nothing +createDraftMetadata input certLevel = do + offchain <- createOffchainMetadata input certLevel + let onchain = createOnchainMetadata input Nothing certLevel pure $ FullMetadata (onchain,offchain) createMetadataAndPushToIpfs :: MonadIO m => AuditorCertificationInput + -> DB.CertificationLevel -> m (FullMetadata,IpfsCid) -createMetadataAndPushToIpfs input = do - offchain <- createOffchainMetadata input +createMetadataAndPushToIpfs input certLevel = do + offchain <- createOffchainMetadata input certLevel finalOffchain <- addIpfsToMetadataIfNecessary offchain ipfsCid <- uploadToIpfs finalOffchain - let onchain = createOnchainMetadata input $ Just (finalOffchain,[toMetadataUrl ipfsCid]) + let onchain = createOnchainMetadata input + (Just (finalOffchain,[toMetadataUrl ipfsCid])) + certLevel pure (FullMetadata (onchain,finalOffchain),IpfsCid ipfsCid) where addIpfsToMetadataIfNecessary (offchain :: OffChainMetadata) = do diff --git a/src/Plutus/Certification/Metadata/Types.hs b/src/Plutus/Certification/Metadata/Types.hs index feb7b9c0..6f80cb0d 100644 --- a/src/Plutus/Certification/Metadata/Types.hs +++ b/src/Plutus/Certification/Metadata/Types.hs @@ -28,12 +28,13 @@ import Data.Text.Encoding as Text import Data.Vector import Plutus.Certification.Internal import IOHK.Certification.SignatureVerification -import Network.URI -import Data.ByteString (ByteString) -import Control.Monad (when) +import Network.URI +import Data.ByteString (ByteString) +import Control.Monad (when) import qualified IOHK.Certification.Persistence as DB import qualified Data.Swagger.Lens as SL +import qualified Data.Aeson.KeyMap as KM import GHC.OverloadedLabels -------------------------------------------------------------------------------- @@ -472,22 +473,46 @@ instance ToSchema OffChainMetadata where -------------------------------------------------------------------------------- -- | AUDITOR CERTIFICATION INPUT -data AuditorCertificationInput = AuditorCertificationInput +data CertificationInput = CertificationInput { subject :: Subject , certificateIssuer :: CertificateIssuer - , report :: [ReportURL] , summary :: Text , disclaimer :: Text , scripts :: [Script] } deriving (Generic,Show) +data AuditorCertificationInput = AuditorCertificationInput + { certificationInput :: CertificationInput + , report :: [ReportURL] + } deriving (Generic,Show) + instance ToJSON AuditorCertificationInput where - toJSON = genericToJSON defaultOptions + toJSON AuditorCertificationInput{..} = Object (x <> y) + where + x = case toJSON certificationInput of + Object obj -> obj + _ -> KM.empty + y = KM.fromList [ "report" .= report ] instance FromJSON AuditorCertificationInput where - parseJSON = genericParseJSON defaultOptions + parseJSON = withObject "AuditorCertificationInput" $ \v -> AuditorCertificationInput + <$> parseJSON (Object v) + <*> v .:? "report" .!= [] instance ToSchema AuditorCertificationInput where + declareNamedSchema _ = do + certificationInputSchema <- declareSchema (Proxy :: Proxy CertificationInput) + reportSchema <- declareSchemaRef (Proxy :: Proxy [ReportURL]) + return $ NamedSchema (Just "AuditorCertificationInput") $ certificationInputSchema + & properties %~ (`mappend` [ ("report", reportSchema) ]) + +instance ToJSON CertificationInput where + toJSON = genericToJSON defaultOptions + +instance FromJSON CertificationInput where + parseJSON = genericParseJSON defaultOptions + +instance ToSchema CertificationInput where declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions diff --git a/src/Plutus/Certification/Server/Instance.hs b/src/Plutus/Certification/Server/Instance.hs index e1c9e46b..d665f69f 100644 --- a/src/Plutus/Certification/Server/Instance.hs +++ b/src/Plutus/Certification/Server/Instance.hs @@ -198,8 +198,11 @@ server ServerArgs{..} = NamedAPI -- Multiple transactions are going to be broadcasted at the same time and -- therefore we are going to pay multiple fees. -- We have to somehow create a lock mechanism for every certification per run - , createCertification = \(profileId,_) rid@RunID{..} -> withEvent eb StartCertification \ev -> do - addField ev (StartCertificationRunID rid) + , createCertification = \(profileId,_) rid@RunID{..} certInput dryRun -> + withEvent eb CreateL1Certification \ev -> do + + addField ev (CreateL1CertificationRunID rid) + addField ev (CreateL1CertificationDryRun (dryRun == Just True)) -- ensure runId belongs to the owner requireRunIdOwner profileId uuid @@ -207,31 +210,40 @@ server ServerArgs{..} = NamedAPI status <- runConduit (getRuns (setAncestor $ reference ev) rid .| evalStateC Queued consumeRuns) -- sync the run with the db and return the db-run information - DB.Run{runStatus} <- getRunAndSync rid status + DB.Run{runStatus,reportContentId} <- getRunAndSync rid status let certResultM = toCertificationResult status - (IPFS.UploadResponse ipfsCid _) <- maybe - (throwError $ err403 { errBody = "Incompatible status for certification"}) - uploadToIpfs certResultM - addField ev (StartCertificationIpfsCid ipfsCid) - - -- ensure there is no certificate already created - when (runStatus `elem` [DB.ReadyForCertification, DB.Certified]) $ - throwError err403 { errBody = "Certification already started" } + ipfsCid <- case reportContentId of + Just rCid -> pure (DB.IpfsCid rCid) + Nothing -> do + -- ensure the run is finished + unless (runStatus == DB.Succeeded) $ + throwError err403 { errBody = "Transaction status not fit for certification" } + -- upload the report to ipfs + (IPFS.UploadResponse ipfsCid _) <- maybe + (throwError $ err403 { errBody = "can't upload report to ipfs" }) + uploadToIpfs certResultM + -- + -- mark the run as ready for certification + now <- getNow + _ <- withDb (DB.markAsReadyForCertification uuid ipfsCid now) - -- ensure the run is finished - unless (runStatus == DB.Succeeded) $ - throwError err403 { errBody = "Transaction status not fit for certification" } + addField ev (CreateL1CertificationReportIpfsCid ipfsCid) + pure ipfsCid - -- mark the run as ready for certification - now <- getNow - withDb (DB.markAsReadyForCertification uuid ipfsCid now) - >> pure NoContent -- yep, we don't need to return anything + let reportUrl = ReportURL $ parseURIUnsafe ("ipfs://" <> Text.unpack (DB.ipfsCid ipfsCid)) + let auditorCertificationInput = AuditorCertificationInput certInput [reportUrl] - , getCertification = \rid@RunID{..} -> withEvent eb GetCertification \ev -> do - addField ev rid - withDb (DB.getL1Certification uuid) - >>= maybeToServerError err404 "Certification not found" + -- create the certification metadata + case dryRun of + -- if it's a dry run, just return the metadata + Just True ->do + catch (createDraftMetadata auditorCertificationInput certLevel) handleException + -- otherwise push the metadata to ipfs and return the full metadata + _ -> do + (fullMetadata,metadataIpfs) <- catch (createMetadataAndPushToIpfs auditorCertificationInput certLevel) handleException + addField ev (CreateL1CertificationMetadataIpfsCid metadataIpfs) + pure fullMetadata , getRepositoryInfo = \owner repo apiGhAccessTokenM -> withEvent eb GetRepoInfo \ev -> do addField ev (GetRepoInfoOwner owner) @@ -319,9 +331,9 @@ server ServerArgs{..} = NamedAPI addField ev $ CreateAuditorReportFieldProfileId profileId addField ev $ CreateAuditorReportDryRun (dryRun == Just True) case dryRun of - Just True -> catch (createDraftMetadata reportInput) handleException + Just True -> catch (createDraftMetadata reportInput certLevel) handleException _ -> do - (fullMetadata,ipfs) <- catch (createMetadataAndPushToIpfs reportInput) handleException + (fullMetadata,ipfs) <- catch (createMetadataAndPushToIpfs reportInput certLevel) handleException addField ev $ CreateAuditorReportIpfsCid ipfs pure fullMetadata @@ -349,6 +361,8 @@ server ServerArgs{..} = NamedAPI } where + -- TODO: for the moment we use L0 for all the certificates + certLevel = DB.L0 wallet = Wallet.realClient serverWalletArgs handleException :: (MonadError ServerError m ) => SomeException -> m a handleException e = do diff --git a/src/Plutus/Certification/Server/Internal.hs b/src/Plutus/Certification/Server/Internal.hs index 7329427b..3bbb9efd 100644 --- a/src/Plutus/Certification/Server/Internal.hs +++ b/src/Plutus/Certification/Server/Internal.hs @@ -52,9 +52,11 @@ data CreateRunField = CreateRunRef !FlakeRefV1 | CreateRunID !RunIDV1 -data StartCertificationField - = StartCertificationRunID !RunIDV1 - | StartCertificationIpfsCid !DB.IpfsCid +data CreateL1CertificationField + = CreateL1CertificationRunID !RunIDV1 + | CreateL1CertificationReportIpfsCid !DB.IpfsCid + | CreateL1CertificationMetadataIpfsCid !DB.IpfsCid + | CreateL1CertificationDryRun !Bool data GetRepoInfoField = GetRepoInfoOwner !Text @@ -94,7 +96,7 @@ data ServerEventSelector f where GetProfileBalance :: ServerEventSelector DB.ProfileId GetCertification :: ServerEventSelector RunIDV1 GetRepoInfo :: ServerEventSelector GetRepoInfoField - StartCertification :: ServerEventSelector StartCertificationField + CreateL1Certification :: ServerEventSelector CreateL1CertificationField Login :: ServerEventSelector WalletAddress ServerTimestamp :: ServerEventSelector Void GenerateGitHubToken :: ServerEventSelector GenerateGitHubTokenField @@ -141,9 +143,11 @@ renderServerEventSelector CreateRun = ("create-run", \case CreateRunID rid -> ("run-id", toJSON rid) ) -renderServerEventSelector StartCertification = ("start-certification", \case - StartCertificationRunID rid -> ("run-id", toJSON rid) - StartCertificationIpfsCid cid -> ("cid", toJSON cid) +renderServerEventSelector CreateL1Certification = ("start-certification", \case + CreateL1CertificationRunID rid -> ("run-id", toJSON rid) + CreateL1CertificationReportIpfsCid cid -> ("report-ipfs-cid", toJSON cid) + CreateL1CertificationMetadataIpfsCid cid -> ("metadata-ipfs-cid", toJSON cid) + CreateL1CertificationDryRun dryRun -> ("dry-run", toJSON dryRun) ) renderServerEventSelector GetRepoInfo = ("get-repo-info", \case diff --git a/src/Plutus/Certification/Synchronizer.hs b/src/Plutus/Certification/Synchronizer.hs index 732fc408..a645251e 100644 --- a/src/Plutus/Certification/Synchronizer.hs +++ b/src/Plutus/Certification/Synchronizer.hs @@ -12,6 +12,8 @@ module Plutus.Certification.Synchronizer ( startTransactionsMonitor , SynchronizerSelector(..) , renderSynchronizerSelector + -- TODO: remove this export, we are using this just to suppress warnings + , certifyRuns ) where import Plutus.Certification.WalletClient.Transaction @@ -189,7 +191,6 @@ monitorWalletTransactions eb args minAssignmentAmount refAssignments = withEvent >>= resyncWallets (narrowEventBackend InjectProfileWalletSync eb) wc isOurAddress minAssignmentAmount >>= liftIO . writeIORef refAssignments - certifyRuns (subEventBackend ev) wc where wc :: WalletClient wc = realClient args @@ -209,6 +210,7 @@ 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 +-- NOTE: this is momentarily disabled certifyRuns :: (MonadIO m, MonadMask m,MonadError IOException m,MonadReader env m,HasDb env) => EventBackend m r SynchronizerSelector -> WalletClient