From 9923df74bc879b42dcf630ad412f02b75445482e Mon Sep 17 00:00:00 2001 From: Bogdan Manole Date: Wed, 15 Feb 2023 20:26:19 +0200 Subject: [PATCH 1/5] feat: support for private repositories (DAC-484) --- .../build-flake/Main.hs | 10 +- .../dapps-certification-helpers.cabal | 3 + .../generate-flake/Main.hs | 6 +- .../src/IOHK/Certification/Actions.hs | 60 ++++-- .../src/IOHK/Certification/Interface.hs | 5 +- .../.plan.nix/dapps-certification-helpers.nix | 3 + .../.plan.nix/plutus-certification.nix | 6 +- .../.plan.nix/dapps-certification-helpers.nix | 3 + .../.plan.nix/plutus-certification.nix | 8 +- .../.plan.nix/dapps-certification-helpers.nix | 3 + .../.plan.nix/plutus-certification.nix | 6 +- plutus-certification.cabal | 4 +- server/Main.hs | 13 +- src/Plutus/Certification/API.hs | 3 +- src/Plutus/Certification/API/Routes.hs | 14 ++ src/Plutus/Certification/API/Swagger.hs | 2 +- src/Plutus/Certification/GitHubClient.hs | 204 ++++++++++++++++++ src/Plutus/Certification/GithubClient.hs | 79 ------- src/Plutus/Certification/Internal.hs | 37 ++++ src/Plutus/Certification/Local.hs | 30 +-- src/Plutus/Certification/Server/Instance.hs | 54 ++++- src/Plutus/Certification/Server/Internal.hs | 11 +- src/Plutus/Certification/Synchronizer.hs | 3 +- .../Certification/WalletClient/Transaction.hs | 21 +- 24 files changed, 424 insertions(+), 164 deletions(-) create mode 100644 src/Plutus/Certification/GitHubClient.hs delete mode 100644 src/Plutus/Certification/GithubClient.hs create mode 100644 src/Plutus/Certification/Internal.hs diff --git a/dapps-certification-helpers/build-flake/Main.hs b/dapps-certification-helpers/build-flake/Main.hs index 2ff5cb66..5d28b0ab 100644 --- a/dapps-certification-helpers/build-flake/Main.hs +++ b/dapps-certification-helpers/build-flake/Main.hs @@ -10,18 +10,22 @@ import IOHK.Certification.Actions import Observe.Event import Observe.Event.Render.JSON import Observe.Event.Render.IO.JSON -import System.IO +import IOHK.Certification.Interface data Args = Args { flake :: !FilePath + , githubToken :: !(Maybe GitHubAccessToken) } + argsParser :: Parser Args argsParser = Args <$> strArgument ( metavar "FLAKE" <> help "the path to the flake" ) + <*> optional gitHubAccessTokenParser + argsInfo :: ParserInfo Args argsInfo = info (argsParser <**> helper) ( fullDesc @@ -30,8 +34,8 @@ argsInfo = info (argsParser <**> helper) instrumentedMain :: EventBackend IO r MainSelector -> Args -> IO () instrumentedMain backend (Args {..}) = do - res <- buildFlake (narrowEventBackend Build backend) (const $ pure ()) flake - hPutStrLn stdout res + res <- buildFlake (narrowEventBackend Build backend) (const $ pure ()) githubToken flake + putStrLn res main :: IO () main = do diff --git a/dapps-certification-helpers/dapps-certification-helpers.cabal b/dapps-certification-helpers/dapps-certification-helpers.cabal index d77266b2..06ef133d 100644 --- a/dapps-certification-helpers/dapps-certification-helpers.cabal +++ b/dapps-certification-helpers/dapps-certification-helpers.cabal @@ -28,6 +28,7 @@ library resourcet, conduit, conduit-aeson, + optparse-applicative, dapps-certification-interface hs-source-dirs: src other-modules: Paths_dapps_certification_helpers @@ -38,6 +39,7 @@ executable generate-flake build-depends: base, dapps-certification-helpers, + dapps-certification-interface, optparse-applicative, network-uri, eventuo11y, @@ -51,6 +53,7 @@ executable build-flake build-depends: base, dapps-certification-helpers, + dapps-certification-interface, optparse-applicative, eventuo11y main-is: Main.hs diff --git a/dapps-certification-helpers/generate-flake/Main.hs b/dapps-certification-helpers/generate-flake/Main.hs index 660d5ecb..1153d70b 100644 --- a/dapps-certification-helpers/generate-flake/Main.hs +++ b/dapps-certification-helpers/generate-flake/Main.hs @@ -13,10 +13,12 @@ import Observe.Event.Render.JSON import Observe.Event.Render.IO.JSON import System.Directory import Data.Aeson +import IOHK.Certification.Interface data Args = Args { flakeref :: !URI , output :: !FilePath + , githubToken :: !(Maybe GitHubAccessToken) } -- TODO Deduplicate with certification-client @@ -39,6 +41,8 @@ argsParser = Args ( metavar "DIR" <> help "the output directory for the flake (must not exist)" ) + <*> optional gitHubAccessTokenParser + argsInfo :: ParserInfo Args argsInfo = info (argsParser <**> helper) ( fullDesc @@ -50,7 +54,7 @@ instrumentedMain backend (Args {..}) = do withEvent backend CreateOutput \ev -> do addField ev output createDirectory output - generateFlake (narrowEventBackend Generate backend) (const $ pure ()) flakeref output + generateFlake (narrowEventBackend Generate backend) (const $ pure ()) githubToken flakeref output main :: IO () main = do diff --git a/dapps-certification-helpers/src/IOHK/Certification/Actions.hs b/dapps-certification-helpers/src/IOHK/Certification/Actions.hs index 83eebf83..05118b8a 100644 --- a/dapps-certification-helpers/src/IOHK/Certification/Actions.hs +++ b/dapps-certification-helpers/src/IOHK/Certification/Actions.hs @@ -15,9 +15,10 @@ import Network.URI hiding (path) import Control.Exception import Control.Concurrent.Async import Control.Monad.IO.Unlift -import Data.Aeson.Internal -import Data.Aeson.Types -import Data.Aeson.Text +import Data.Aeson.Internal as Aeson +import Data.Aeson.Types as Aeson +import Data.Aeson.Text as Aeson +import Data.Function import Data.Time.Clock.POSIX import Data.Text as T import Data.Text.IO hiding (putStrLn) @@ -47,15 +48,16 @@ import Control.Monad.Trans.Resource import IOHK.Certification.Interface hiding (Success) import Conduit import Data.Conduit.Aeson +import Options.Applicative as Optparse -generateFlake :: EventBackend IO r GenerateFlakeSelector ->(Text -> IO ()) -> URI -> FilePath -> IO () -generateFlake backend addLogEntry flakeref output = withEvent backend GenerateFlake \ev -> do +generateFlake :: EventBackend IO r GenerateFlakeSelector -> (Text -> IO ()) -> Maybe GitHubAccessToken -> URI -> FilePath -> IO () +generateFlake backend addLogEntry ghAccessTokenM flakeref output = withEvent backend GenerateFlake \ev -> do addField ev $ GenerateRef flakeref addField ev $ GenerateDir output let lockBackend = narrowEventBackend LockFlake $ subEventBackend ev - lock <- lockRef lockBackend flakeref + lock <- lockRef lockBackend ghAccessTokenM flakeref let logWrittenFile fname = addLogEntry $ T.pack $ fname ++ " written at " ++ output withSubEvent ev WriteFlakeNix \_ -> withFile (output "flake.nix") WriteMode \h -> do @@ -89,8 +91,8 @@ generateFlake backend addLogEntry flakeref output = withEvent backend GenerateFl logWrittenFile "Certify.nix" -buildFlake :: EventBackend IO r BuildFlakeSelector -> (Text -> IO ()) -> FilePath -> IO FilePath -buildFlake backend addLogEntry dir = do +buildFlake :: EventBackend IO r BuildFlakeSelector -> (Text -> IO ()) -> Maybe GitHubAccessToken -> FilePath -> IO FilePath +buildFlake backend addLogEntry ghAccessTokenM dir = do buildJson <- withEvent backend BuildingFlake \ev -> do let backend' = narrowEventBackend ReadNixBuild $ subEventBackend ev @@ -108,15 +110,15 @@ buildFlake backend addLogEntry dir = do , "--no-link" , "--json" , "--print-build-logs" - ] + ] & setGitHubAccessToken ghAccessTokenM runCertify :: (Text -> IO ()) -> FilePath -> ConduitT () Message ResIO () runCertify addLogEntry certify = do (k, p) <- allocateAcquire $ acquireProcessWait cfg let toMessage = await >>= \case Just (Right (_, v)) -> case fromJSON v of - Error s -> liftIO $ fail s - Success m -> do + Aeson.Error s -> liftIO $ fail s + Aeson.Success m -> do liftIO $ addLogEntry $ LT.toStrict $ encodeToLazyText v yield m toMessage @@ -195,7 +197,7 @@ decodeFlakeLock = iparse $ withObject "flake-metadata" \o -> do ghTy :: Text ghTy = "github" - decodeRev :: JSONPath -> Text -> Parser SHA1Hash + decodeRev :: JSONPath -> Text -> Aeson.Parser SHA1Hash decodeRev path r = case parseSHA1Hash r of Left (NotBase16 msg) -> parserThrowError path $ "rev " ++ (show r) ++ " is not valid base16: " ++ (show msg) @@ -260,14 +262,14 @@ readProcessLogStderr_ backend cfg addLogEntry = withEvent backend LaunchingProc backend' = causedEventBackend launchEv readStderrBackend = narrowEventBackend ReadingStderr - $ backend' + backend' readStderr = logHandleText readStderrBackend addLogEntry $ getStderr p readStdoutBackend = narrowEventBackend ReadingStdout - $ backend' + backend' - readStdout = (LBS.fromChunks . Prelude.reverse) + readStdout = LBS.fromChunks . Prelude.reverse <$> logDrainHandle readStdoutBackend (getStdout p) (\bs -> pure . (bs :)) [] withRunInIO \run -> withAsync (run readStdout) \stdoutAsync -> @@ -279,10 +281,10 @@ readProcessLogStderr_ backend cfg addLogEntry = withEvent backend LaunchingProc where cfg' = setStdout createPipe $ setStderr createPipe - $ cfg + cfg -lockRef :: EventBackend IO r LockSelector -> URI -> IO FlakeLock -lockRef backend flakeref = withEvent backend LockingFlake \ev -> do +lockRef :: EventBackend IO r LockSelector -> Maybe GitHubAccessToken -> URI -> IO FlakeLock +lockRef backend ghAccessTokenM flakeref = withEvent backend LockingFlake \ev -> do addField ev $ LockingRef flakeref meta <- withSubEvent ev GettingMetadata \metaEv -> do let backend' = narrowEventBackend ReadNixFlakeMetadata @@ -299,8 +301,24 @@ lockRef backend flakeref = withEvent backend LockingFlake \ev -> do , "metadata" , "--no-update-lock-file" , "--json" - , (uriToString id flakeref "") - ] + , uriToString id flakeref "" + ] & setGitHubAccessToken ghAccessTokenM + +setGitHubAccessToken :: Maybe GitHubAccessToken + -> ProcessConfig stdin stdout stderr + -> ProcessConfig stdin stdout stderr +setGitHubAccessToken Nothing = id +setGitHubAccessToken (Just (GitHubAccessToken token)) = + let var = "access-tokens = github.com=" <> T.unpack token + in setEnv [("NIX_CONFIG", var)] + +gitHubAccessTokenParser :: Optparse.Parser GitHubAccessToken +gitHubAccessTokenParser = GitHubAccessToken + <$> option str + ( long "gh-access-token" + <> metavar "GH_ACCESS_TOKEN" + <> help "GitHub access token to be used for authentication in case of private repos or restricted access is needed" + ) data BuildResult = BuildResult { drvPath :: !FilePath @@ -314,7 +332,7 @@ decodeBuild = iparse $ withArray "build-results" \builds -> do decoded <- V.mapM decodeResult builds pure $ V.unsafeHead decoded :| V.toList (V.unsafeTail decoded) where - decodeResult :: Value -> Parser BuildResult + decodeResult :: Value -> Aeson.Parser BuildResult decodeResult = withObject "build-result" \o -> BuildResult <$> o .: "drvPath" <*> o .: "outputs" diff --git a/dapps-certification-interface/src/IOHK/Certification/Interface.hs b/dapps-certification-interface/src/IOHK/Certification/Interface.hs index 89ce684a..bff28b1f 100644 --- a/dapps-certification-interface/src/IOHK/Certification/Interface.hs +++ b/dapps-certification-interface/src/IOHK/Certification/Interface.hs @@ -2,9 +2,6 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE EmptyCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} module IOHK.Certification.Interface where @@ -128,6 +125,8 @@ data TaskResult = TaskResult , succeeded :: !Bool } deriving Generic +newtype GitHubAccessToken = GitHubAccessToken { unGitHubAccessToken :: Text } + deriving (Eq, Generic) instance ToSchema TaskResult instance ToJSON TaskResult where diff --git a/nix/materialized/aarch64-darwin/.plan.nix/dapps-certification-helpers.nix b/nix/materialized/aarch64-darwin/.plan.nix/dapps-certification-helpers.nix index 0175fe26..e2fc5d43 100644 --- a/nix/materialized/aarch64-darwin/.plan.nix/dapps-certification-helpers.nix +++ b/nix/materialized/aarch64-darwin/.plan.nix/dapps-certification-helpers.nix @@ -56,6 +56,7 @@ (hsPkgs."resourcet" or (errorHandler.buildDepError "resourcet")) (hsPkgs."conduit" or (errorHandler.buildDepError "conduit")) (hsPkgs."conduit-aeson" or (errorHandler.buildDepError "conduit-aeson")) + (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) (hsPkgs."dapps-certification-interface" or (errorHandler.buildDepError "dapps-certification-interface")) ]; buildable = true; @@ -70,6 +71,7 @@ depends = [ (hsPkgs."base" or (errorHandler.buildDepError "base")) (hsPkgs."dapps-certification-helpers" or (errorHandler.buildDepError "dapps-certification-helpers")) + (hsPkgs."dapps-certification-interface" or (errorHandler.buildDepError "dapps-certification-interface")) (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) (hsPkgs."network-uri" or (errorHandler.buildDepError "network-uri")) (hsPkgs."eventuo11y" or (errorHandler.buildDepError "eventuo11y")) @@ -84,6 +86,7 @@ depends = [ (hsPkgs."base" or (errorHandler.buildDepError "base")) (hsPkgs."dapps-certification-helpers" or (errorHandler.buildDepError "dapps-certification-helpers")) + (hsPkgs."dapps-certification-interface" or (errorHandler.buildDepError "dapps-certification-interface")) (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) (hsPkgs."eventuo11y" or (errorHandler.buildDepError "eventuo11y")) ]; diff --git a/nix/materialized/aarch64-darwin/.plan.nix/plutus-certification.nix b/nix/materialized/aarch64-darwin/.plan.nix/plutus-certification.nix index 28153327..32709815 100644 --- a/nix/materialized/aarch64-darwin/.plan.nix/plutus-certification.nix +++ b/nix/materialized/aarch64-darwin/.plan.nix/plutus-certification.nix @@ -72,8 +72,9 @@ "Plutus/Certification/API/Routes" "Plutus/Certification/API/Swagger" "Plutus/Certification/Web3StorageClient" + "Plutus/Certification/Internal" "Plutus/Certification/WalletClient/Transaction" - "Plutus/Certification/Server/TransactionBroadcaster" + "Plutus/Certification/TransactionBroadcaster" "Plutus/Certification/Server/Internal" "Plutus/Certification/Server/Instance" "Plutus/Certification/API" @@ -82,7 +83,7 @@ "Plutus/Certification/Client" "Plutus/Certification/Server" "Plutus/Certification/Local" - "Plutus/Certification/GithubClient" + "Plutus/Certification/GitHubClient" "Plutus/Certification/WalletClient" "Plutus/Certification/Synchronizer" ]; @@ -113,6 +114,7 @@ (hsPkgs."exceptions" or (errorHandler.buildDepError "exceptions")) (hsPkgs."plutus-certification" or (errorHandler.buildDepError "plutus-certification")) (hsPkgs."dapps-certification-persistence" or (errorHandler.buildDepError "dapps-certification-persistence")) + (hsPkgs."dapps-certification-helpers" or (errorHandler.buildDepError "dapps-certification-helpers")) (hsPkgs."swagger2" or (errorHandler.buildDepError "swagger2")) (hsPkgs."servant-swagger-ui" or (errorHandler.buildDepError "servant-swagger-ui")) ]; diff --git a/nix/materialized/x86_64-darwin/.plan.nix/dapps-certification-helpers.nix b/nix/materialized/x86_64-darwin/.plan.nix/dapps-certification-helpers.nix index 0175fe26..e2fc5d43 100644 --- a/nix/materialized/x86_64-darwin/.plan.nix/dapps-certification-helpers.nix +++ b/nix/materialized/x86_64-darwin/.plan.nix/dapps-certification-helpers.nix @@ -56,6 +56,7 @@ (hsPkgs."resourcet" or (errorHandler.buildDepError "resourcet")) (hsPkgs."conduit" or (errorHandler.buildDepError "conduit")) (hsPkgs."conduit-aeson" or (errorHandler.buildDepError "conduit-aeson")) + (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) (hsPkgs."dapps-certification-interface" or (errorHandler.buildDepError "dapps-certification-interface")) ]; buildable = true; @@ -70,6 +71,7 @@ depends = [ (hsPkgs."base" or (errorHandler.buildDepError "base")) (hsPkgs."dapps-certification-helpers" or (errorHandler.buildDepError "dapps-certification-helpers")) + (hsPkgs."dapps-certification-interface" or (errorHandler.buildDepError "dapps-certification-interface")) (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) (hsPkgs."network-uri" or (errorHandler.buildDepError "network-uri")) (hsPkgs."eventuo11y" or (errorHandler.buildDepError "eventuo11y")) @@ -84,6 +86,7 @@ depends = [ (hsPkgs."base" or (errorHandler.buildDepError "base")) (hsPkgs."dapps-certification-helpers" or (errorHandler.buildDepError "dapps-certification-helpers")) + (hsPkgs."dapps-certification-interface" or (errorHandler.buildDepError "dapps-certification-interface")) (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) (hsPkgs."eventuo11y" or (errorHandler.buildDepError "eventuo11y")) ]; diff --git a/nix/materialized/x86_64-darwin/.plan.nix/plutus-certification.nix b/nix/materialized/x86_64-darwin/.plan.nix/plutus-certification.nix index 02836c90..32709815 100644 --- a/nix/materialized/x86_64-darwin/.plan.nix/plutus-certification.nix +++ b/nix/materialized/x86_64-darwin/.plan.nix/plutus-certification.nix @@ -72,8 +72,9 @@ "Plutus/Certification/API/Routes" "Plutus/Certification/API/Swagger" "Plutus/Certification/Web3StorageClient" + "Plutus/Certification/Internal" "Plutus/Certification/WalletClient/Transaction" - "Plutus/Certification/Server/TransactionBroadcaster" + "Plutus/Certification/TransactionBroadcaster" "Plutus/Certification/Server/Internal" "Plutus/Certification/Server/Instance" "Plutus/Certification/API" @@ -82,7 +83,7 @@ "Plutus/Certification/Client" "Plutus/Certification/Server" "Plutus/Certification/Local" - "Plutus/Certification/GithubClient" + "Plutus/Certification/GitHubClient" "Plutus/Certification/WalletClient" "Plutus/Certification/Synchronizer" ]; @@ -113,6 +114,7 @@ (hsPkgs."exceptions" or (errorHandler.buildDepError "exceptions")) (hsPkgs."plutus-certification" or (errorHandler.buildDepError "plutus-certification")) (hsPkgs."dapps-certification-persistence" or (errorHandler.buildDepError "dapps-certification-persistence")) + (hsPkgs."dapps-certification-helpers" or (errorHandler.buildDepError "dapps-certification-helpers")) (hsPkgs."swagger2" or (errorHandler.buildDepError "swagger2")) (hsPkgs."servant-swagger-ui" or (errorHandler.buildDepError "servant-swagger-ui")) ]; @@ -146,4 +148,4 @@ }; }; }; - } // rec { src = (pkgs.lib).mkDefault ../.; } + } // rec { src = (pkgs.lib).mkDefault ../.; } \ No newline at end of file diff --git a/nix/materialized/x86_64-linux/.plan.nix/dapps-certification-helpers.nix b/nix/materialized/x86_64-linux/.plan.nix/dapps-certification-helpers.nix index 0175fe26..e2fc5d43 100644 --- a/nix/materialized/x86_64-linux/.plan.nix/dapps-certification-helpers.nix +++ b/nix/materialized/x86_64-linux/.plan.nix/dapps-certification-helpers.nix @@ -56,6 +56,7 @@ (hsPkgs."resourcet" or (errorHandler.buildDepError "resourcet")) (hsPkgs."conduit" or (errorHandler.buildDepError "conduit")) (hsPkgs."conduit-aeson" or (errorHandler.buildDepError "conduit-aeson")) + (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) (hsPkgs."dapps-certification-interface" or (errorHandler.buildDepError "dapps-certification-interface")) ]; buildable = true; @@ -70,6 +71,7 @@ depends = [ (hsPkgs."base" or (errorHandler.buildDepError "base")) (hsPkgs."dapps-certification-helpers" or (errorHandler.buildDepError "dapps-certification-helpers")) + (hsPkgs."dapps-certification-interface" or (errorHandler.buildDepError "dapps-certification-interface")) (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) (hsPkgs."network-uri" or (errorHandler.buildDepError "network-uri")) (hsPkgs."eventuo11y" or (errorHandler.buildDepError "eventuo11y")) @@ -84,6 +86,7 @@ depends = [ (hsPkgs."base" or (errorHandler.buildDepError "base")) (hsPkgs."dapps-certification-helpers" or (errorHandler.buildDepError "dapps-certification-helpers")) + (hsPkgs."dapps-certification-interface" or (errorHandler.buildDepError "dapps-certification-interface")) (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) (hsPkgs."eventuo11y" or (errorHandler.buildDepError "eventuo11y")) ]; diff --git a/nix/materialized/x86_64-linux/.plan.nix/plutus-certification.nix b/nix/materialized/x86_64-linux/.plan.nix/plutus-certification.nix index 28153327..32709815 100644 --- a/nix/materialized/x86_64-linux/.plan.nix/plutus-certification.nix +++ b/nix/materialized/x86_64-linux/.plan.nix/plutus-certification.nix @@ -72,8 +72,9 @@ "Plutus/Certification/API/Routes" "Plutus/Certification/API/Swagger" "Plutus/Certification/Web3StorageClient" + "Plutus/Certification/Internal" "Plutus/Certification/WalletClient/Transaction" - "Plutus/Certification/Server/TransactionBroadcaster" + "Plutus/Certification/TransactionBroadcaster" "Plutus/Certification/Server/Internal" "Plutus/Certification/Server/Instance" "Plutus/Certification/API" @@ -82,7 +83,7 @@ "Plutus/Certification/Client" "Plutus/Certification/Server" "Plutus/Certification/Local" - "Plutus/Certification/GithubClient" + "Plutus/Certification/GitHubClient" "Plutus/Certification/WalletClient" "Plutus/Certification/Synchronizer" ]; @@ -113,6 +114,7 @@ (hsPkgs."exceptions" or (errorHandler.buildDepError "exceptions")) (hsPkgs."plutus-certification" or (errorHandler.buildDepError "plutus-certification")) (hsPkgs."dapps-certification-persistence" or (errorHandler.buildDepError "dapps-certification-persistence")) + (hsPkgs."dapps-certification-helpers" or (errorHandler.buildDepError "dapps-certification-helpers")) (hsPkgs."swagger2" or (errorHandler.buildDepError "swagger2")) (hsPkgs."servant-swagger-ui" or (errorHandler.buildDepError "servant-swagger-ui")) ]; diff --git a/plutus-certification.cabal b/plutus-certification.cabal index b879731f..51ac6a58 100644 --- a/plutus-certification.cabal +++ b/plutus-certification.cabal @@ -59,7 +59,7 @@ library Plutus.Certification.Client Plutus.Certification.Server Plutus.Certification.Local - Plutus.Certification.GithubClient + Plutus.Certification.GitHubClient Plutus.Certification.WalletClient Plutus.Certification.Synchronizer other-modules: @@ -67,6 +67,7 @@ library Plutus.Certification.API.Routes Plutus.Certification.API.Swagger Plutus.Certification.Web3StorageClient + Plutus.Certification.Internal Plutus.Certification.WalletClient.Transaction Plutus.Certification.TransactionBroadcaster Plutus.Certification.Server.Internal @@ -98,6 +99,7 @@ executable plutus-certification exceptions ^>= 0.10.4, plutus-certification, dapps-certification-persistence, + dapps-certification-helpers, swagger2, servant-swagger-ui, main-is: Main.hs diff --git a/server/Main.hs b/server/Main.hs index daa207a4..6a0376d2 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -53,9 +53,10 @@ import Paths_plutus_certification qualified as Package import IOHK.Certification.Persistence qualified as DB import Network.HTTP.Types.Method import Plutus.Certification.WalletClient -import Plutus.Certification.Synchronizer +import Plutus.Certification.Synchronizer +import Plutus.Certification.GitHubClient import Control.Concurrent (forkIO) - +import IOHK.Certification.Actions data Backend = Local | Cicero !BaseUrl @@ -64,7 +65,8 @@ data Args = Args { port :: !Port , host :: !HostPreference , backend :: !Backend - , wallet :: WalletArgs + , wallet :: !WalletArgs + , githubToken :: !(Maybe GitHubAccessToken) } baseUrlReader :: ReadM BaseUrl @@ -111,6 +113,7 @@ argsParser = Args ) <*> (localParser <|> ciceroParser) <*> walletParser + <*> optional gitHubAccessTokenParser walletParser :: Parser WalletArgs walletParser = WalletArgs @@ -260,7 +263,7 @@ main = do . narrowEventBackend InjectRunClient $ eb ) $ CiceroCaps {..} - Local -> hoistServerCaps liftIO <$> localServerCaps ( narrowEventBackend InjectLocal eb ) + Local -> hoistServerCaps liftIO <$> localServerCaps ( narrowEventBackend InjectLocal eb ) args.githubToken let settings = defaultSettings & setPort args.port & setHost args.host @@ -280,7 +283,7 @@ main = do runSettings settings . application (narrowEventBackend InjectServeRequest eb) $ cors (const $ Just corsPolicy) . serveWithContext (Proxy @APIWithSwagger) genAuthServerContext . - (\r -> swaggerSchemaUIServer swaggerJson :<|> server caps (args.wallet) (be r eb)) + (\r -> swaggerSchemaUIServer swaggerJson :<|> server caps (ServerArgs args.wallet args.githubToken) (be r eb)) exitFailure where diff --git a/src/Plutus/Certification/API.hs b/src/Plutus/Certification/API.hs index 66d7e121..f751373e 100644 --- a/src/Plutus/Certification/API.hs +++ b/src/Plutus/Certification/API.hs @@ -19,8 +19,9 @@ import Plutus.Certification.API.Routes as X , KnownActionType(..) , ProfileBody(..) , DAppBody(..) + , ApiGitHubAccessToken(..) ) -import Plutus.Certification.API.Swagger as X +import Plutus.Certification.API.Swagger as X ( swaggerJson , APIWithSwagger ) diff --git a/src/Plutus/Certification/API/Routes.hs b/src/Plutus/Certification/API/Routes.hs index 666f00c8..77a1c4a7 100644 --- a/src/Plutus/Certification/API/Routes.hs +++ b/src/Plutus/Certification/API/Routes.hs @@ -37,6 +37,7 @@ import Plutus.Certification.WalletClient import qualified IOHK.Certification.Persistence as DB import qualified IOHK.Cicero.API.Run as Cicero.Run (RunLog(..)) import qualified Control.Lens as L +import Plutus.Certification.GitHubClient (RepositoryInfo) type API = NamedRoutes NamedAPI @@ -124,6 +125,17 @@ type WalletAddressRoute = "wallet-address" :> Description "Get the wallet address the backend operates with" :> Get '[JSON] WalletAddress +type GitHubRoute = "repo" + :> Description "Get the github repo information" + :> Capture "owner" Text + :> Capture "repo" Text + :> Servant.Header "Authorization" ApiGitHubAccessToken + :> Get '[JSON] RepositoryInfo + +newtype ApiGitHubAccessToken = ApiGitHubAccessToken { unApiGitHubAccessToken :: Text } + deriving (Generic) + deriving newtype (ToHttpApiData, FromHttpApiData ) + newtype CertificateCreationResponse = CertificateCreationResponse { certCreationReportId :: Text } @@ -143,6 +155,7 @@ data NamedAPI mode = NamedAPI , walletAddress :: mode :- WalletAddressRoute , getProfileBalance :: mode :- GetBalanceRoute , getRunDetails :: mode :- GetRunDetailsRoute + , getRepositoryInfo :: mode :- GitHubRoute } deriving stock Generic data DAppBody = DAppBody @@ -382,6 +395,7 @@ instance ToSchema CertifyingStatus instance ToSchema RunIDV1 instance ToParamSchema RunIDV1 instance ToParamSchema KnownActionType +instance ToParamSchema ApiGitHubAccessToken instance ToSchema DAppBody where declareNamedSchema _ = do diff --git a/src/Plutus/Certification/API/Swagger.hs b/src/Plutus/Certification/API/Swagger.hs index 85caa801..e6a64602 100644 --- a/src/Plutus/Certification/API/Swagger.hs +++ b/src/Plutus/Certification/API/Swagger.hs @@ -36,7 +36,7 @@ type UnnamedApi :<|> GetCertificateRoute :<|> GetBalanceRoute :<|> WalletAddressRoute - :<|> GetRunDetailsRoute + :<|> GitHubRoute instance (HasSwagger sub) => HasSwagger (AuthProtect "public-key" :> sub) where toSwagger _ = toSwagger (Proxy :: Proxy (Servant.Header "Authorization" Text :> sub)) diff --git a/src/Plutus/Certification/GitHubClient.hs b/src/Plutus/Certification/GitHubClient.hs new file mode 100644 index 00000000..82f6033e --- /dev/null +++ b/src/Plutus/Certification/GitHubClient.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedLists #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Plutus.Certification.GitHubClient + ( getCommitInfo + , Author(..) + , Commit(..) + , CommitDetails(..) + , GitHubAccessToken(..) + , RepositoryInfo(..) + , getRepoInfo + ) where + +import Data.Aeson +import Control.Lens hiding (index, (.=)) +import Data.Proxy +import GHC.Generics +import Network.HTTP.Client hiding (Proxy) +import Network.HTTP.Client.TLS +import Servant.API +import Servant.Client +import Data.Text +import Data.Swagger hiding (Contact,Header,Https) +import Data.Time +import IOHK.Certification.Interface +import Plutus.Certification.Internal + +newtype BranchResponse = BranchResponse { commonRespCommit :: Commit } + deriving (Show, Generic) + +data Author = Author + { name :: !Text + , email :: !Text + , date :: !UTCTime +} deriving (Show, Generic) + +data CommitDetails = CommitDetails + { author :: !Author + , message :: !Text + , committer :: !Author + } deriving (Show, Generic) + +data Commit = Commit + { sha :: !Text + , commit :: !CommitDetails + } deriving (Show, Generic) + +data RepositoryInfo = RepositoryInfo + { repoName :: !Text + , repoOwner :: !RepositoryOwner + , repoDefaultBranch :: !Text + , repoDescription :: !(Maybe Text) + , repoPrivate :: !Bool + } deriving (Show, Generic) + deriving (FromJSON,ToJSON) via (JSONCustomOptions 4 RepositoryInfo) + +data RepositoryOwner = RepositoryOwner + { ownerLogin :: !(Maybe Text) + , ownerId :: !(Maybe Int) + , ownerNodeId :: !(Maybe Text) + , ownerAvatarUrl :: !(Maybe Text) + , ownerGravatarId :: !(Maybe Text) + , ownerUrl :: !(Maybe Text) + , ownerHtmlUrl :: !(Maybe Text) + , ownerFollowersUrl :: !(Maybe Text) + , ownerFollowingUrl :: !(Maybe Text) + , ownerGistsUrl :: !(Maybe Text) + , ownerStarredUrl :: !(Maybe Text) + , ownerSubscriptionsUrl :: !(Maybe Text) + , ownerOrganizationsUrl :: !(Maybe Text) + , ownerReposUrl :: !(Maybe Text) + , ownerEventsUrl :: !(Maybe Text) + , ownerReceivedEventsUrl :: !(Maybe Text) + , ownerType :: !(Maybe Text) + , ownerSiteAdmin :: !(Maybe Bool) + } deriving (Show, Generic) + deriving (FromJSON,ToJSON) via (JSONCustomOptions 5 RepositoryOwner) + +instance ToSchema RepositoryInfo where + declareNamedSchema _ = do + textSchema <- declareSchemaRef (Proxy :: Proxy Text) + ownerSchema <- declareSchemaRef (Proxy :: Proxy RepositoryOwner) + return $ NamedSchema (Just "RepositoryInfo") $ mempty + & type_ ?~ SwaggerObject + & properties .~ + [ ("name", textSchema) + , ("owner", ownerSchema) + , ("default_branch", textSchema) + , ("description", textSchema) + , ("private", textSchema) + ] + & required .~ ["name", "owner", "default_branch", "private"] + +instance ToSchema RepositoryOwner where + declareNamedSchema _ = do + textSchema <- declareSchemaRef (Proxy :: Proxy Text) + return $ NamedSchema (Just "RepositoryOwner") $ mempty + & type_ ?~ SwaggerObject + & properties .~ + [ ("login", textSchema) + , ("id", textSchema) + , ("node_id", textSchema) + , ("avatar_url", textSchema) + , ("gravatar_id", textSchema) + , ("url", textSchema) + , ("html_url", textSchema) + , ("followers_url", textSchema) + , ("following_url", textSchema) + , ("gists_url", textSchema) + , ("starred_url", textSchema) + , ("subscriptions_url", textSchema) + , ("organizations_url", textSchema) + , ("repos_url", textSchema) + , ("events_url", textSchema) + , ("received_events_url", textSchema) + , ("type", textSchema) + , ("site_admin", textSchema) + ] + & required .~ [] + +instance FromJSON BranchResponse where + parseJSON = withObject "BranchResponse" $ \v -> BranchResponse <$> v .: "commit" + +instance FromJSON Commit +instance FromJSON CommitDetails +instance FromJSON Author + +type API = "repos" + :> Header "User-Agent" Text + :> Header "Authorization" GitHubAccessToken + :> Capture "owner" Text + :> Capture "repo" Text + :> ( "branches" :> Capture "branch" Text :> Get '[JSON] BranchResponse + :<|> "commits" :> Capture "commit" Text :> Get '[JSON] Commit + :<|> Get '[JSON] RepositoryInfo + ) + +api :: Proxy API +api = Proxy + +type Repo = Text +type Owner = Text + +mkClient :: Maybe GitHubAccessToken + -> Repo + -> Owner + -> (Text -> ClientM BranchResponse) + :<|> (Text -> ClientM Commit) + :<|> ClientM RepositoryInfo +mkClient = client api (Just "") + +instance ToHttpApiData GitHubAccessToken where + toUrlPiece = ("Bearer " <>) . unGitHubAccessToken + +-- | Binds the client to a specific owner , repo and github access token +-- also applies same settings and https github domain +-- returns a tuple of 3 functions: getBranch, getCommit, getRepo +bindClient :: Maybe GitHubAccessToken + -> Repo + -> Owner + -> ( Text -> IO (Either ClientError BranchResponse) + , Text -> IO (Either ClientError Commit) + , IO (Either ClientError RepositoryInfo) + ) +bindClient githubAccessToken owner repo = + ( \path' -> mkSettings >>= runClientM (getBranch path' ) + , \path' -> mkSettings >>= runClientM (getCommit path' ) + , mkSettings >>= runClientM getRepo + ) + where + mkSettings = flip mkClientEnv (BaseUrl Https "api.github.com" 443 "") + <$> newManager tlsManagerSettings + getBranch :<|> getCommit :<|> getRepo = mkClient githubAccessToken owner repo + +-- | Tries to get the commit info from a branch, +-- if it fails it tries to get it from the commit +getCommitInfo :: Maybe GitHubAccessToken + -> Repo + -> Owner + -> Text + -> IO (Either ClientError Commit) +getCommitInfo githubAccessToken owner repo path' = do + let (getBranch, getCommit,_) = bindClient githubAccessToken owner repo + -- first try branch + respE <- getBranch path' + case respE of + Left _ -> getCommit path' + Right (BranchResponse commit') -> pure (Right commit') + +-- | Tries to get the github repository info +getRepoInfo :: Maybe GitHubAccessToken + -> Repo + -> Owner + -> IO (Either ClientError RepositoryInfo) +getRepoInfo githubAccessToken owner repo = do + let (_, _, getRepo') = bindClient githubAccessToken owner repo + getRepo' + diff --git a/src/Plutus/Certification/GithubClient.hs b/src/Plutus/Certification/GithubClient.hs deleted file mode 100644 index 653a9894..00000000 --- a/src/Plutus/Certification/GithubClient.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedStrings #-} - -module Plutus.Certification.GithubClient ( - getCommitInfo, - Author(..), - Commit(..), - CommitDetails(..) - ) where - -import Data.Aeson -import Data.Proxy -import GHC.Generics -import Network.HTTP.Client hiding (Proxy) -import Network.HTTP.Client.TLS -import Servant.API -import Servant.Client -import Data.Text -import Data.Time - -data BranchResponse = BranchResponse { - commonRespCommit :: Commit -} deriving (Show, Generic) - -data Author = Author - { name :: Text - , email :: Text - , date :: UTCTime -} deriving (Show, Generic) - -data CommitDetails = CommitDetails - { author :: Author - , message :: Text - , committer :: Author - } deriving (Show, Generic) - -data Commit = Commit - { sha :: Text - , commit :: CommitDetails - } deriving (Show, Generic) - -instance FromJSON BranchResponse where - parseJSON = withObject "BranchResponse" $ \v -> BranchResponse <$> v .: "commit" - -instance FromJSON Commit -instance FromJSON CommitDetails -instance FromJSON Author - -type API = "repos" - :> Header "User-Agent" Text - :> Capture "owner" Text - :> Capture "repo" Text - :> ( "branches" :> Capture "branch" Text :> Get '[JSON] BranchResponse - :<|> "commits" :> Capture "commit" Text :> Get '[JSON] Commit - ) - -api :: Proxy API -api = Proxy - -mkClient :: Text -> Text -> (Text -> ClientM BranchResponse) :<|> (Text -> ClientM Commit) -mkClient = (client api) (Just "") - -getCommitInfo :: Text - -> Text - -> Text - -> IO (Either ClientError Commit) -getCommitInfo owner repo path' = do - manager' <- newManager tlsManagerSettings - let settings = (mkClientEnv manager' (BaseUrl Https "api.github.com" 443 "")) - let getBranch :<|> getCommit = mkClient owner repo - - -- first try branch - respE <- runClientM (getBranch path' ) settings - case respE of - Left _ -> runClientM (getCommit path' ) settings - Right (BranchResponse commit') -> pure (Right commit') - diff --git a/src/Plutus/Certification/Internal.hs b/src/Plutus/Certification/Internal.hs new file mode 100644 index 00000000..243b5431 --- /dev/null +++ b/src/Plutus/Certification/Internal.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} + +module Plutus.Certification.Internal where +import Data.Aeson +import GHC.Generics +import Data.Proxy +import GHC.TypeLits + +newtype JSONCustomOptions n a = JSONCustomOptions a deriving Generic + +defaultRecordTypeOptions :: Int -> Options +defaultRecordTypeOptions n = defaultOptions + { fieldLabelModifier = camelTo2 '_' . drop n + , constructorTagModifier = camelTo2 '_' . drop n + } + +instance (Generic a, GToJSON' Value Zero (Rep a),KnownNat n) => ToJSON (JSONCustomOptions n a) + where + toJSON (JSONCustomOptions x) = genericToJSON (defaultRecordTypeOptions (nToDrop @n)) x + +nToDrop :: forall n. KnownNat n => Int +nToDrop = fromInteger $ natVal (Proxy :: Proxy n) + +instance (Generic a, GFromJSON Zero (Rep a), KnownNat n) => FromJSON (JSONCustomOptions n a) + where + parseJSON = fmap JSONCustomOptions . genericParseJSON (defaultRecordTypeOptions (nToDrop @n)) diff --git a/src/Plutus/Certification/Local.hs b/src/Plutus/Certification/Local.hs index aeca2e50..fc2c3f2c 100644 --- a/src/Plutus/Certification/Local.hs +++ b/src/Plutus/Certification/Local.hs @@ -32,11 +32,12 @@ import qualified Data.Text as T import Control.Exception import Control.Monad +import Data.Maybe (isNothing) data JobState = JobState - { statuses :: ![(Maybe [CertificationTask] -> RunStatusV1)] + { statuses :: ![Maybe [CertificationTask] -> RunStatusV1] , plan :: !(Maybe [CertificationTask]) - , logs :: (LocalActionLogs T.Text) + , logs :: !(LocalActionLogs T.Text) } emptyLocalLog :: LocalActionLogs a @@ -46,7 +47,7 @@ emptyJobState :: JobState emptyJobState = JobState [] Nothing emptyLocalLog addStatus :: (Maybe [CertificationTask] -> RunStatusV1) -> JobState -> JobState -addStatus st js = js { statuses = st : (statuses js) } +addStatus st js = js { statuses = st : statuses js } setPlan :: [CertificationTask] -> JobState -> JobState setPlan p js = js { plan = Just p } @@ -69,8 +70,10 @@ addLocalLog actionType val js@JobState{..} = js { logs = newLogs} Build -> logs { build = val:(logs.build)} Certify -> logs { certify = val:(logs.certify)} -localServerCaps :: EventBackend IO r LocalSelector -> IO (ServerCaps IO r) -localServerCaps backend = do +localServerCaps :: EventBackend IO r LocalSelector + -> Maybe GitHubAccessToken + -> IO (ServerCaps IO r) +localServerCaps backend ghAccessTokenM = do jobs <- newIORef Map.empty cancellations <- newIORef Map.empty let @@ -101,14 +104,15 @@ localServerCaps backend = do addField rEv $ TempDir dir addStatus' . const $ Incomplete (Preparing Running) catch - (generateFlake (narrowEventBackend InjectGenerate $ subEventBackend rEv) (addLogEntry Generate) uri dir) + (generateFlake (narrowEventBackend InjectGenerate $ + subEventBackend rEv) (addLogEntry Generate) ghAccessTokenM uri dir) (\(ex :: SomeException) -> do addLogEntry Generate (T.pack $ show ex) addStatus' . const $ Incomplete (Preparing Failed) ) addStatus' . const $ Incomplete (Building Running) certifyOut <- onException - (buildFlake (narrowEventBackend InjectBuild $ subEventBackend rEv) (addLogEntry Build) dir) + (buildFlake (narrowEventBackend InjectBuild $ subEventBackend rEv) (addLogEntry Build) ghAccessTokenM dir) (addStatus' . const $ Incomplete (Building Failed)) addStatus' $ \p -> Incomplete (Certifying (CertifyingStatus Running Nothing p)) let go = await >>= \case @@ -124,11 +128,11 @@ localServerCaps backend = do (runConduitRes $ runCertify (addLogEntry Certify) (certifyOut "bin" "certify") .| go) (addStatus' $ \pl -> Incomplete (Certifying $ CertifyingStatus Failed Nothing pl)) -- TODO get latest actual status update - (async $ finally runJob (freeCancellation jobId)) >>= addCancellation jobId + async ( finally runJob (freeCancellation jobId)) >>= addCancellation jobId pure $ coerce jobId - getRuns _ (RunID jobId) = - getStatuses <$> (Map.findWithDefault emptyJobState jobId)<$> (lift $ readIORef jobs) >>= yieldMany + getRuns _ (RunID jobId) = lift (readIORef jobs) + >>= yieldMany . getStatuses . Map.findWithDefault emptyJobState jobId abortRuns mods rid@(RunID jobId) = withEvent (modifyEventBackend mods backend) AbortJob \ev -> do addField ev rid @@ -137,7 +141,7 @@ localServerCaps backend = do getLogs _ actionTypeM (RunID jobId) = do (JobState _ _ (LocalActionLogs generate build certify)) <- - Map.findWithDefault emptyJobState jobId <$> (lift $ readIORef jobs) + Map.findWithDefault emptyJobState jobId <$> lift (readIORef jobs) whenMatches Generate yield' generate whenMatches Build yield' build @@ -148,7 +152,7 @@ localServerCaps backend = do yieldMany (reverse logs) .| mapC (toRunLog (source actionType)) whenMatches actionType yieldLogs logs = when - (actionTypeM == Nothing || actionTypeM == (Just actionType)) + (isNothing actionTypeM || actionTypeM == Just actionType) (yieldLogs logs actionType) toRunLog src (ztime,text) = RunLog ztime src text @@ -188,7 +192,7 @@ renderSubmitJobField :: RenderFieldJSON SubmitJobField renderSubmitJobField (SubmittedRef u) = ("submitted-ref", toJSON $ uriToString id u "") renderSubmitJobField (JobID jobId) = ("job-id", toJSON jobId) -data RunningJobField = TempDir !FilePath +newtype RunningJobField = TempDir FilePath renderRunningJobField :: RenderFieldJSON RunningJobField renderRunningJobField (TempDir p) = ("temp-dir", toJSON p) diff --git a/src/Plutus/Certification/Server/Instance.hs b/src/Plutus/Certification/Server/Instance.hs index 80bd2052..3d5ddc81 100644 --- a/src/Plutus/Certification/Server/Instance.hs +++ b/src/Plutus/Certification/Server/Instance.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} @@ -15,12 +16,13 @@ module Plutus.Certification.Server.Instance where import Conduit import Control.Monad.Catch import Servant +import Servant.Client as Client import Control.Monad.State.Strict import Observe.Event import Observe.Event.BackendModification import Network.URI import Plutus.Certification.API as API -import Plutus.Certification.GithubClient +import Plutus.Certification.GitHubClient import Control.Monad.Except import Data.Time.LocalTime import Data.Maybe @@ -28,7 +30,7 @@ import Data.Aeson import Network.HTTP.Client hiding (Proxy,parseUrl) import Network.HTTP.Types - +import Control.Applicative import Data.Text as Text hiding (elem,replicate, last) import Data.Text.Encoding import Plutus.Certification.WalletClient (WalletArgs(walletCertificationPrice)) @@ -49,16 +51,24 @@ hoistServerCaps nt (ServerCaps {..}) = ServerCaps , getLogs = \mods act -> transPipe nt . getLogs mods act } +-- | A type for server arguments including the wallet arguments +-- and the github access token as optional + +data ServerArgs = ServerArgs + { walletArgs :: Wallet.WalletArgs + , githubToken :: Maybe GitHubAccessToken + } + -- | An implementation of 'API' server :: (MonadMask m,MonadIO m, MonadError ServerError m) => ServerCaps m r - -> Wallet.WalletArgs + -> ServerArgs -> EventBackend m r ServerEventSelector -> ServerT API m -server ServerCaps {..} wargs eb = NamedAPI +server ServerCaps {..} ServerArgs{..} eb = NamedAPI { version = withEvent eb Version . const . pure $ VersionV1 Package.version , versionHead = withEvent eb Version . const $ pure NoContent - , walletAddress = withEvent eb WalletAddress . const $ pure wargs.walletAddress + , walletAddress = withEvent eb WalletAddress . const $ pure walletArgs.walletAddress , createRun = \(profileId,_) commitOrBranch -> withEvent eb CreateRun \ev -> do fref <- getFlakeRef profileId commitOrBranch -- ensure the ref is in the right format before start the job @@ -157,8 +167,36 @@ server ServerCaps {..} wargs eb = NamedAPI addField ev rid DB.withDb (DB.getCertification uuid) >>= maybeToServerError err404 "Certification not found" + , getRepositoryInfo = \owner repo apiGhAccessTokenM -> withEvent eb GetRepoInfo \ev -> do + addField ev (GetRepoInfoOwner owner) + addField ev (GetRepoInfoRepo repo) + let ghAccessTokenM = GitHubAccessToken . unApiGitHubAccessToken + <$> apiGhAccessTokenM + -- if there is no github access token, we use the default one + -- provided from arguments + ghAccessTokenM' = ghAccessTokenM <|> githubToken + liftIO ( getRepoInfo ghAccessTokenM' owner repo ) >>= fromClientResponse } where + fromClientResponse = \case + Left err -> throwError $ serverErrorFromClientError err + Right a -> pure a + serverErrorFromClientError :: ClientError -> ServerError + serverErrorFromClientError clientResponse = + case clientResponse of + FailureResponse _ resp -> errorFromClientResponse resp + DecodeFailure _ resp -> err500WithResp resp + UnsupportedContentType _ resp -> err500WithResp resp + InvalidContentTypeHeader resp -> err500WithResp resp + ConnectionError _ -> err500 {errBody = "Connection error"} + where + err500WithResp resp = err500 {errBody = LSB.pack $ show resp} + + errorFromClientResponse :: Client.Response -> ServerError + errorFromClientResponse resp = + let (Status code msg) = responseStatusCode resp + err = ServerError code "GitHub API error" (LSB.fromStrict msg) [] + in err uploadToIpfs :: (Monad m, MonadIO m, MonadError ServerError m) => CertificationResult -> m IPFS.UploadResponse uploadToIpfs certResultM = do resp <- IPFS.uploadReportToIpfs IPFS.apiKey (LSB.toStrict $ encode certResultM) @@ -212,7 +250,9 @@ server ServerCaps {..} wargs eb = NamedAPI getCommitDateAndHash FlakeRef{..} = do (owner,repo,path') <- extractUriSegments uri - commitInfoE <- liftIO $ getCommitInfo owner repo path' + -- TODO: here we might have to use a github token + -- provided by the user for authorizing our app to access a private repo + commitInfoE <- liftIO $ getCommitInfo githubToken owner repo path' case commitInfoE of Left e -> throwError err400 { errBody = LSB.pack $ show e} Right (Commit hash (CommitDetails _ _ (Author _ _ time))) -> pure (time,hash) @@ -225,4 +265,4 @@ server ServerCaps {..} wargs eb = NamedAPI now <- getNow let uriTxt = pack $ uriToString id uri "" DB.withDb $ DB.createRun (uuid res) now uriTxt commitDate - commitHash (wargs.walletCertificationPrice) profileId + commitHash (walletArgs.walletCertificationPrice) profileId diff --git a/src/Plutus/Certification/Server/Internal.hs b/src/Plutus/Certification/Server/Internal.hs index b0f05d72..a00c4ca0 100644 --- a/src/Plutus/Certification/Server/Internal.hs +++ b/src/Plutus/Certification/Server/Internal.hs @@ -48,6 +48,10 @@ data StartCertificationField = StartCertificationRunID !RunIDV1 | StartCertificationIpfsCid !DB.IpfsCid +data GetRepoInfoField + = GetRepoInfoOwner !Text + | GetRepoInfoRepo !Text + -- | CreateCertificationTxResponse !Wallet.TxResponse data ServerEventSelector f where @@ -60,6 +64,7 @@ data ServerEventSelector f where GetRunLogs :: ServerEventSelector RunIDV1 GetProfileBalance :: ServerEventSelector DB.ProfileId GetCertification :: ServerEventSelector RunIDV1 + GetRepoInfo :: ServerEventSelector GetRepoInfoField StartCertification :: ServerEventSelector StartCertificationField renderServerEventSelector :: RenderSelectorJSON ServerEventSelector @@ -80,7 +85,11 @@ renderServerEventSelector CreateRun = ("create-run", \case renderServerEventSelector StartCertification = ("start-certification", \case StartCertificationRunID rid -> ("run-id", toJSON rid) StartCertificationIpfsCid cid -> ("cid", toJSON cid) - --CreateCertificationTxResponse txResp -> ("tx-resp",toJSON txResp) + ) + +renderServerEventSelector GetRepoInfo = ("get-repo-info", \case + GetRepoInfoOwner owner -> ("owner", toJSON owner) + GetRepoInfoRepo repo -> ("repo", toJSON repo) ) renderRunIDV1 :: RenderFieldJSON RunIDV1 diff --git a/src/Plutus/Certification/Synchronizer.hs b/src/Plutus/Certification/Synchronizer.hs index 156f624d..a7f8b90f 100644 --- a/src/Plutus/Certification/Synchronizer.hs +++ b/src/Plutus/Certification/Synchronizer.hs @@ -38,7 +38,6 @@ import Data.Maybe (fromMaybe) import Observe.Event.Backend import Observe.Event - data InitializingField = WalletArgsField WalletArgs | DelayField Int @@ -223,6 +222,8 @@ startTransactionsMonitor :: (MonadIO m,MonadMask m,MonadError IOException m) startTransactionsMonitor eb args delayInSeconds = withEvent eb InitializingSynchronizer $ \ev -> do addField ev $ WalletArgsField args addField ev $ DelayField delayInSeconds + -- TODO maybe a forkIO here will be better than into the calling function + -- hence, now, the parent instrumentation event will never terminate forever $ do monitorWalletTransactions (subEventBackend ev) args liftIO $ threadDelay delayInMicroseconds diff --git a/src/Plutus/Certification/WalletClient/Transaction.hs b/src/Plutus/Certification/WalletClient/Transaction.hs index fe544a34..7ba771b4 100644 --- a/src/Plutus/Certification/WalletClient/Transaction.hs +++ b/src/Plutus/Certification/WalletClient/Transaction.hs @@ -9,7 +9,6 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GADTs #-} @@ -24,28 +23,10 @@ import Control.Monad import Data.Proxy import Data.Time import GHC.TypeLits +import Plutus.Certification.Internal import qualified Data.Aeson.KeyMap as KM -newtype JSONCustomOptions n a = JSONCustomOptions a deriving Generic - -defaultRecordTypeOptions :: Int -> Options -defaultRecordTypeOptions n = defaultOptions - { fieldLabelModifier = camelTo2 '_' . drop n - , constructorTagModifier = camelTo2 '_' . drop n - } - -instance (Generic a, GToJSON' Value Zero (Rep a),KnownNat n) => ToJSON (JSONCustomOptions n a) - where - toJSON (JSONCustomOptions x) = genericToJSON (defaultRecordTypeOptions (nToDrop @n)) x - -nToDrop :: forall n. KnownNat n => Int -nToDrop = fromInteger $ natVal (Proxy :: Proxy n) - -instance (Generic a, GFromJSON Zero (Rep a), KnownNat n) => FromJSON (JSONCustomOptions n a) - where - parseJSON = fmap JSONCustomOptions . genericParseJSON (defaultRecordTypeOptions (nToDrop @n)) - newtype Quantity unit = Quantity { quantity :: Int } deriving (Show,Eq,Generic) type LovelaceQty = Quantity "lovelace" From 69a1bfcab30e872cf076584ce1d8b6bcbf53f250 Mon Sep 17 00:00:00 2001 From: Bogdan Manole Date: Sat, 18 Feb 2023 23:06:02 +0200 Subject: [PATCH 2/5] feat: add option for separate github token for every dapp (DAC-484) --- client/Main.hs | 32 ++++++++++ .../src/IOHK/Certification/Actions.hs | 15 +++-- .../src/IOHK/Certification/Interface.hs | 58 +++++++++++++++++- .../src/IOHK/Certification/Persistence/API.hs | 15 +++-- .../Certification/Persistence/Structure.hs | 19 +++--- .../.plan.nix/plutus-certification.nix | 1 + .../.plan.nix/plutus-certification.nix | 1 + .../.plan.nix/plutus-certification.nix | 1 + plutus-certification.cabal | 1 + server/Main.hs | 4 +- src/Plutus/Certification/API/Routes.hs | 61 ++++++++++++++++--- src/Plutus/Certification/Cicero.hs | 2 +- src/Plutus/Certification/GitHubClient.hs | 2 +- src/Plutus/Certification/Local.hs | 5 +- src/Plutus/Certification/Server/Instance.hs | 20 +++--- src/Plutus/Certification/Server/Internal.hs | 2 +- 16 files changed, 195 insertions(+), 44 deletions(-) diff --git a/client/Main.hs b/client/Main.hs index d036dab0..a5c75ff0 100644 --- a/client/Main.hs +++ b/client/Main.hs @@ -25,6 +25,7 @@ import Data.Aeson import Data.Time.LocalTime import Data.Time import Data.Text as Text +import IOHK.Certification.Actions (gitHubAccessTokenParser) type PublicKey = ByteString @@ -238,6 +239,7 @@ dappBodyParser = DAppBody <> metavar "DAPP_VERSION" <> help "dapp version" ) + <*> optional (ApiGitHubAccessToken <$> gitHubAccessTokenParser) profileBodyParser :: Parser ProfileBody profileBodyParser = ProfileBody @@ -296,6 +298,13 @@ data Command | CmdVersion | CmdWalletAddress | CmdCurrentProfile !ProfileCommand + | CmdGetRepositoryInfo !GetRepositoryInfoArgs + +data GetRepositoryInfoArgs = GetGitHubAddressArgs + { owner :: !Text + , repo :: !Text + , gitHubAccessToken :: !(Maybe ApiGitHubAccessToken) + } data ProfileCommand = GetCurrentProfile !PublicKey @@ -309,8 +318,29 @@ commandParser = hsubparser <> command "version" (CmdVersion <$ versionCommandInfo) <> command "profile" (CmdCurrentProfile <$> currentProfileInfo) <> command "wallet-address" (CmdWalletAddress <$ walletAddressCommandInfo) + <> command "get-repo-info" (CmdGetRepositoryInfo <$> getGitHubRepoInfo) + ) + +getGitHubRepoInfo :: ParserInfo GetRepositoryInfoArgs +getGitHubRepoInfo = info getGitHubRepoParser + ( fullDesc + <> header "plutus-certification-client get-github-repo — Get the github repo information" ) +getGitHubRepoParser :: Parser GetRepositoryInfoArgs +getGitHubRepoParser = GetGitHubAddressArgs + <$> option str + ( long "owner" + <> metavar "GITHUB_OWNER" + <> help "github owner" + ) + <*> option str + ( long "repo" + <> metavar "GITHUB_REPO" + <> help "github repo" + ) + <*> optional (ApiGitHubAccessToken <$> gitHubAccessTokenParser) + data Args = Args { certificationURL :: !BaseUrl , certificationUser :: !(Maybe PublicKey) @@ -384,3 +414,5 @@ main = do handle $ apiClient.getCurrentProfile (addAuth pubKey) CmdCurrentProfile (UpdateCurrentProfile (UpdateCurrentProfileArgs pubKey profileBody)) -> handle $ apiClient.updateCurrentProfile (addAuth pubKey) profileBody + CmdGetRepositoryInfo (GetGitHubAddressArgs owner' repo' gitHubAccessToken') -> + handle $ apiClient.getRepositoryInfo owner' repo' gitHubAccessToken' diff --git a/dapps-certification-helpers/src/IOHK/Certification/Actions.hs b/dapps-certification-helpers/src/IOHK/Certification/Actions.hs index 05118b8a..a8d1481e 100644 --- a/dapps-certification-helpers/src/IOHK/Certification/Actions.hs +++ b/dapps-certification-helpers/src/IOHK/Certification/Actions.hs @@ -308,13 +308,20 @@ setGitHubAccessToken :: Maybe GitHubAccessToken -> ProcessConfig stdin stdout stderr -> ProcessConfig stdin stdout stderr setGitHubAccessToken Nothing = id -setGitHubAccessToken (Just (GitHubAccessToken token)) = - let var = "access-tokens = github.com=" <> T.unpack token +setGitHubAccessToken (Just ghAccessToken) = + let token = ghAccessTokenToText ghAccessToken + var = "access-tokens = github.com=" <> T.unpack token in setEnv [("NIX_CONFIG", var)] +gitHubAccessTokenReader :: ReadM GitHubAccessToken +gitHubAccessTokenReader = do + text <- str + case ghAccessTokenFromText text of + Left err -> readerError $ "couldn't parse '" ++ T.unpack text ++ "' as a GitHub access token: " ++ err + Right ghAccessToken -> pure ghAccessToken + gitHubAccessTokenParser :: Optparse.Parser GitHubAccessToken -gitHubAccessTokenParser = GitHubAccessToken - <$> option str +gitHubAccessTokenParser = option gitHubAccessTokenReader ( long "gh-access-token" <> metavar "GH_ACCESS_TOKEN" <> help "GitHub access token to be used for authentication in case of private repos or restricted access is needed" diff --git a/dapps-certification-interface/src/IOHK/Certification/Interface.hs b/dapps-certification-interface/src/IOHK/Certification/Interface.hs index bff28b1f..3e4e5f8c 100644 --- a/dapps-certification-interface/src/IOHK/Certification/Interface.hs +++ b/dapps-certification-interface/src/IOHK/Certification/Interface.hs @@ -10,8 +10,9 @@ import GHC.Generics import Control.Applicative import Data.Aeson hiding (Success, Error) import Data.Aeson.Encoding -import Data.Text hiding (index) +import Data.Text as Text hiding (index) import Data.Swagger +import Data.Char (isAlphaNum) -- | Renderable certification task names. data CertificationTaskName @@ -125,8 +126,59 @@ data TaskResult = TaskResult , succeeded :: !Bool } deriving Generic -newtype GitHubAccessToken = GitHubAccessToken { unGitHubAccessToken :: Text } - deriving (Eq, Generic) +data GitHubAccessTokenType + = PersonalToken + | OAuthToken + | UserToServerToken + | ServerToServerToken + | RefreshToken + deriving (Eq, Generic) +data GitHubAccessToken = GitHubAccessToken + { ghAccessTokenPrefix :: GitHubAccessTokenType + , ghAccessTokenSuffix :: Text + } deriving (Eq, Generic) + +-- | Parse a GitHub access token. +-- The token must be of the form "ghA_XXXXX" where +-- is A is a letter of p,o,u,s or r and XXXXX is a sequence of 36 alphanumeric +ghAccessTokenFromText :: Text -> Either String GitHubAccessToken +ghAccessTokenFromText t = case Text.splitOn "_" t of + [pfx, sfx] -> do + pfx' <- case pfx of + "ghp" -> Right PersonalToken + "gho" -> Right OAuthToken + "ghu" -> Right UserToServerToken + "ghs" -> Right ServerToServerToken + "ghr" -> Right RefreshToken + _ -> Left "invalid prefix" + sfx' <- if Text.length sfx == 36 && Text.all isAlphaNum sfx + then Right sfx + else Left "invalid suffix" + Right $ GitHubAccessToken pfx' sfx' + _ -> Left "invalid token" + +-- | Parse a GitHub access token without error handling. +-- see 'ghAccessTokenFromText' for details. +-- This function is unsafe because it can throw an error +-- if the token is not known to be valid. +-- To be used only when the token is known to be valid (eg. from the database or a config file) +knownGhAccessTokenFromText :: Text -> GitHubAccessToken +knownGhAccessTokenFromText t = case ghAccessTokenFromText t of + Left err -> error err + Right t' -> t' + +-- | Render a GitHub access token. +ghAccessTokenToText :: GitHubAccessToken -> Text +ghAccessTokenToText (GitHubAccessToken t s) = + let prefix' = case t of + PersonalToken -> "ghp" + OAuthToken -> "gho" + UserToServerToken -> "ghu" + ServerToServerToken -> "ghs" + RefreshToken -> "ghr" + in prefix' <> "_" <> s + + instance ToSchema TaskResult instance ToJSON TaskResult where diff --git a/dapps-certification-persistence/src/IOHK/Certification/Persistence/API.hs b/dapps-certification-persistence/src/IOHK/Certification/Persistence/API.hs index 3dc82070..499edba1 100644 --- a/dapps-certification-persistence/src/IOHK/Certification/Persistence/API.hs +++ b/dapps-certification-persistence/src/IOHK/Certification/Persistence/API.hs @@ -90,19 +90,21 @@ upsertProfile profile@Profile{..} dappM = do void $ upsert profiles (\p -> p ! #ownerAddress .== text ownerAddress) (`with` - [ #website := fromTextMaybe website - , #vendor := fromTextMaybe vendor - , #twitter := fromTextMaybe twitter - , #linkedin := fromTextMaybe linkedin - , #authors := fromTextMaybe authors - , #contacts := fromTextMaybe contacts + [ #website := fromTextMaybe website + , #vendor := fromTextMaybe vendor + , #twitter := fromTextMaybe twitter + , #linkedin := fromTextMaybe linkedin + , #authors := fromTextMaybe authors + , #contacts := fromTextMaybe contacts ]) [#profileId (def :: ID Profile) profile] -- we query this because upsert returns id only when inserts profileIdM <- getProfileId ownerAddress forM_ profileIdM $ \pid -> case dappM of + -- if there is no dapp we delete the dapp entry Nothing -> do void $ deleteFrom dapps (\dapp -> dapp ! #dappId .== literal pid) + -- if there is a dapp we upsert it Just dapp@DApp{..} -> do void $ upsert dapps (\dapp' -> dapp' ! #dappId .== literal pid) @@ -112,6 +114,7 @@ upsertProfile profile@Profile{..} dappM = do , #dappRepo := text dappRepo , #dappVersion := text dappVersion , #dappId := literal profileId + , #dappGitHubToken := literal dappGitHubToken ] ) [dapp { dappId = pid }] diff --git a/dapps-certification-persistence/src/IOHK/Certification/Persistence/Structure.hs b/dapps-certification-persistence/src/IOHK/Certification/Persistence/Structure.hs index ec38d5fc..315617a8 100644 --- a/dapps-certification-persistence/src/IOHK/Certification/Persistence/Structure.hs +++ b/dapps-certification-persistence/src/IOHK/Certification/Persistence/Structure.hs @@ -47,13 +47,13 @@ type ProfileId = ID Profile instance FromJSON Profile where parseJSON = withObject "Profile" $ \v -> Profile def - <$> v .: "address" - <*> v .:? "website" .!= Nothing - <*> v .:? "vendor" .!= Nothing - <*> v .:? "twitter" .!= Nothing - <*> v .:? "linkedin" .!= Nothing - <*> v .:? "authors" .!= Nothing - <*> v .:? "contacts" .!= Nothing + <$> v .: "address" + <*> v .:? "website" .!= Nothing + <*> v .:? "vendor" .!= Nothing + <*> v .:? "twitter" .!= Nothing + <*> v .:? "linkedin" .!= Nothing + <*> v .:? "authors" .!= Nothing + <*> v .:? "contacts" .!= Nothing instance ToSchema Profile where declareNamedSchema _ = do @@ -70,6 +70,7 @@ instance ToSchema Profile where , ("linkedin", textSchemaM) , ("authors", textSchemaM) , ("contacts", textSchemaM) + , ("githubToken", textSchemaM) ] & required .~ [ "address", "dapp" ] @@ -129,6 +130,7 @@ data DApp = DApp , dappOwner :: Text , dappRepo :: Text , dappVersion :: Text + , dappGitHubToken :: Maybe Text } deriving (Generic,Show) instance ToSchema DApp where @@ -141,6 +143,7 @@ instance ToSchema DApp where , ("owner", textSchema) , ("repo", textSchema) , ("version", textSchema) + , ("githubToken", textSchema) ] & required .~ ["name", "owner", "repo", "version"] @@ -150,6 +153,7 @@ instance FromJSON DApp where <*> v .: "owner" <*> v .: "repo" <*> v .: "version" + <*> v .: "githubToken" instance ToJSON DApp where toJSON (DApp{..}) = object @@ -157,6 +161,7 @@ instance ToJSON DApp where , "owner" .= dappOwner , "repo" .= dappRepo , "version" .= dappVersion + , "githubToken" .= dappGitHubToken ] instance SqlRow DApp diff --git a/nix/materialized/aarch64-darwin/.plan.nix/plutus-certification.nix b/nix/materialized/aarch64-darwin/.plan.nix/plutus-certification.nix index 32709815..a28d2db1 100644 --- a/nix/materialized/aarch64-darwin/.plan.nix/plutus-certification.nix +++ b/nix/materialized/aarch64-darwin/.plan.nix/plutus-certification.nix @@ -140,6 +140,7 @@ (hsPkgs."time" or (errorHandler.buildDepError "time")) (hsPkgs."text" or (errorHandler.buildDepError "text")) (hsPkgs."http-types" or (errorHandler.buildDepError "http-types")) + (hsPkgs."dapps-certification-helpers" or (errorHandler.buildDepError "dapps-certification-helpers")) (hsPkgs."plutus-certification" or (errorHandler.buildDepError "plutus-certification")) ]; buildable = true; diff --git a/nix/materialized/x86_64-darwin/.plan.nix/plutus-certification.nix b/nix/materialized/x86_64-darwin/.plan.nix/plutus-certification.nix index 32709815..a28d2db1 100644 --- a/nix/materialized/x86_64-darwin/.plan.nix/plutus-certification.nix +++ b/nix/materialized/x86_64-darwin/.plan.nix/plutus-certification.nix @@ -140,6 +140,7 @@ (hsPkgs."time" or (errorHandler.buildDepError "time")) (hsPkgs."text" or (errorHandler.buildDepError "text")) (hsPkgs."http-types" or (errorHandler.buildDepError "http-types")) + (hsPkgs."dapps-certification-helpers" or (errorHandler.buildDepError "dapps-certification-helpers")) (hsPkgs."plutus-certification" or (errorHandler.buildDepError "plutus-certification")) ]; buildable = true; diff --git a/nix/materialized/x86_64-linux/.plan.nix/plutus-certification.nix b/nix/materialized/x86_64-linux/.plan.nix/plutus-certification.nix index 32709815..a28d2db1 100644 --- a/nix/materialized/x86_64-linux/.plan.nix/plutus-certification.nix +++ b/nix/materialized/x86_64-linux/.plan.nix/plutus-certification.nix @@ -140,6 +140,7 @@ (hsPkgs."time" or (errorHandler.buildDepError "time")) (hsPkgs."text" or (errorHandler.buildDepError "text")) (hsPkgs."http-types" or (errorHandler.buildDepError "http-types")) + (hsPkgs."dapps-certification-helpers" or (errorHandler.buildDepError "dapps-certification-helpers")) (hsPkgs."plutus-certification" or (errorHandler.buildDepError "plutus-certification")) ]; buildable = true; diff --git a/plutus-certification.cabal b/plutus-certification.cabal index 51ac6a58..578c646d 100644 --- a/plutus-certification.cabal +++ b/plutus-certification.cabal @@ -125,6 +125,7 @@ executable plutus-certification-client time ^>= 1.11.1.1, text ^>= 1.2.5.0, http-types ^>= 0.12.3, + dapps-certification-helpers, plutus-certification main-is: Main.hs hs-source-dirs: client diff --git a/server/Main.hs b/server/Main.hs index 6a0376d2..972547a9 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -56,7 +56,7 @@ import Plutus.Certification.WalletClient import Plutus.Certification.Synchronizer import Plutus.Certification.GitHubClient import Control.Concurrent (forkIO) -import IOHK.Certification.Actions +import IOHK.Certification.Actions data Backend = Local | Cicero !BaseUrl @@ -263,7 +263,7 @@ main = do . narrowEventBackend InjectRunClient $ eb ) $ CiceroCaps {..} - Local -> hoistServerCaps liftIO <$> localServerCaps ( narrowEventBackend InjectLocal eb ) args.githubToken + Local -> hoistServerCaps liftIO <$> localServerCaps ( narrowEventBackend InjectLocal eb ) let settings = defaultSettings & setPort args.port & setHost args.host diff --git a/src/Plutus/Certification/API/Routes.hs b/src/Plutus/Certification/API/Routes.hs index 77a1c4a7..bd7ed7e5 100644 --- a/src/Plutus/Certification/API/Routes.hs +++ b/src/Plutus/Certification/API/Routes.hs @@ -10,6 +10,8 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLists #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -33,11 +35,12 @@ import IOHK.Certification.Interface import Data.Time import Data.Proxy import Plutus.Certification.WalletClient - import qualified IOHK.Certification.Persistence as DB import qualified IOHK.Cicero.API.Run as Cicero.Run (RunLog(..)) -import qualified Control.Lens as L +import Control.Lens hiding ((.=)) +import qualified Data.Swagger.Lens as SL import Plutus.Certification.GitHubClient (RepositoryInfo) +import Control.Arrow (ArrowChoice(left)) type API = NamedRoutes NamedAPI @@ -132,9 +135,26 @@ type GitHubRoute = "repo" :> Servant.Header "Authorization" ApiGitHubAccessToken :> Get '[JSON] RepositoryInfo -newtype ApiGitHubAccessToken = ApiGitHubAccessToken { unApiGitHubAccessToken :: Text } +newtype ApiGitHubAccessToken = ApiGitHubAccessToken { unApiGitHubAccessToken :: GitHubAccessToken } deriving (Generic) - deriving newtype (ToHttpApiData, FromHttpApiData ) + +instance ToJSON ApiGitHubAccessToken where + toJSON = toJSON . ghAccessTokenToText . unApiGitHubAccessToken + +instance FromJSON ApiGitHubAccessToken where + parseJSON = withObject "ApiGitHubAccessToken" $ \o -> do + token <- o .: "token" + case ghAccessTokenFromText token of + Left err -> fail err + Right t -> pure $ ApiGitHubAccessToken t + +instance ToHttpApiData ApiGitHubAccessToken where + -- | Convert a 'GitHubAccessToken' to a 'Text' value. + toUrlPiece = ghAccessTokenToText . unApiGitHubAccessToken + +instance FromHttpApiData ApiGitHubAccessToken where + -- | Parse a 'GitHubAccessToken' from a 'Text' value. + parseUrlPiece = left Text.pack . fmap ApiGitHubAccessToken . ghAccessTokenFromText newtype CertificateCreationResponse = CertificateCreationResponse { certCreationReportId :: Text @@ -163,6 +183,7 @@ data DAppBody = DAppBody , dappOwner :: Text , dappRepo :: Text , dappVersion :: Text + , dappGitHubToken :: Maybe ApiGitHubAccessToken } deriving stock Generic instance FromJSON DAppBody where @@ -171,6 +192,7 @@ instance FromJSON DAppBody where <*> v .: "owner" <*> v .: "repo" <*> v .: "version" + <*> v .: "githubToken" instance ToJSON DAppBody where toJSON DAppBody{..} = object @@ -178,6 +200,7 @@ instance ToJSON DAppBody where , "owner" .= dappOwner , "repo" .= dappRepo , "version" .= dappVersion + , "githubToken" .= dappGitHubToken ] data ProfileBody = ProfileBody @@ -395,24 +418,46 @@ instance ToSchema CertifyingStatus instance ToSchema RunIDV1 instance ToParamSchema RunIDV1 instance ToParamSchema KnownActionType -instance ToParamSchema ApiGitHubAccessToken + + +instance ToParamSchema ApiGitHubAccessToken where + toParamSchema _ = mempty + & type_ ?~ SwaggerString + & maxLength ?~ 40 + -- we use SL qualified because of an issue + -- of parsing for the hlint. it seems to be + -- some kind of bug + & SL.pattern ?~ ghAccessTokenPattern + +ghAccessTokenPattern :: Pattern +ghAccessTokenPattern = "^gh[oprst]_[A-Za-z0-9]{36}$" + + +instance ToSchema ApiGitHubAccessToken where + declareNamedSchema _ = do + return $ NamedSchema (Just "ApiGitHubAccessToken") $ mempty + & type_ ?~ SwaggerString + & maxLength ?~ 40 + & SL.pattern ?~ ghAccessTokenPattern instance ToSchema DAppBody where declareNamedSchema _ = do profileSchema <- declareSchema (Proxy :: Proxy DB.DApp) - return $ NamedSchema (Just "DAppBody") profileSchema + apiGitHubAccessTokenSchema <- declareSchemaRef (Proxy :: Proxy ApiGitHubAccessToken) + return $ NamedSchema (Just "DAppBody") $ profileSchema + & properties . at "githubToken" ?~ apiGitHubAccessTokenSchema instance ToSchema ProfileBody instance ToSchema FlakeRefV1 where declareNamedSchema _ = do return $ NamedSchema (Just "FlakeRefV1") $ mempty - L.& type_ L.?~ SwaggerString + & type_ ?~ SwaggerString instance ToSchema CommitOrBranch where declareNamedSchema _ = do return $ NamedSchema (Just "CommitOrBranch") $ mempty - L.& type_ L.?~ SwaggerString + & type_ ?~ SwaggerString instance ToSchema Cicero.Run.RunLog where --TODO: find a way to embed aeson Value to the definition diff --git a/src/Plutus/Certification/Cicero.hs b/src/Plutus/Certification/Cicero.hs index fe2b250c..6c85a381 100644 --- a/src/Plutus/Certification/Cicero.hs +++ b/src/Plutus/Certification/Cicero.hs @@ -83,7 +83,7 @@ data CiceroCaps c m r = CiceroCaps ciceroServerCaps :: forall c m r . (MonadMask m, HasClient c Cicero.API) => EventBackend m r RunClientSelector -> CiceroCaps c m r -> ServerCaps m r ciceroServerCaps backend CiceroCaps {..} = ServerCaps {..} where - submitJob mods ref = RunID . (.id.uuid) <$> runClientOrDie clientCaps backend' req + submitJob mods _ ref = RunID . (.id.uuid) <$> runClientOrDie clientCaps backend' req where backend' = modifyEventBackend mods backend uri = ref.uri -- aesonQQ's parser doesn't support RecordDot yet diff --git a/src/Plutus/Certification/GitHubClient.hs b/src/Plutus/Certification/GitHubClient.hs index 82f6033e..d162f9cb 100644 --- a/src/Plutus/Certification/GitHubClient.hs +++ b/src/Plutus/Certification/GitHubClient.hs @@ -156,7 +156,7 @@ mkClient :: Maybe GitHubAccessToken mkClient = client api (Just "") instance ToHttpApiData GitHubAccessToken where - toUrlPiece = ("Bearer " <>) . unGitHubAccessToken + toUrlPiece = ("Bearer " <>) . ghAccessTokenToText -- | Binds the client to a specific owner , repo and github access token -- also applies same settings and https github domain diff --git a/src/Plutus/Certification/Local.hs b/src/Plutus/Certification/Local.hs index fc2c3f2c..bbb68652 100644 --- a/src/Plutus/Certification/Local.hs +++ b/src/Plutus/Certification/Local.hs @@ -71,15 +71,14 @@ addLocalLog actionType val js@JobState{..} = js { logs = newLogs} Certify -> logs { certify = val:(logs.certify)} localServerCaps :: EventBackend IO r LocalSelector - -> Maybe GitHubAccessToken -> IO (ServerCaps IO r) -localServerCaps backend ghAccessTokenM = do +localServerCaps backend = do jobs <- newIORef Map.empty cancellations <- newIORef Map.empty let freeCancellation jobId = atomicModifyIORef' cancellations (\rs -> (Map.delete jobId rs, ())) addCancellation jobId run= atomicModifyIORef' cancellations (\rs -> (Map.insert jobId (cancel run) rs, ())) - submitJob mods (FlakeRef uri) = withEvent (modifyEventBackend mods backend) SubmitJob \ev -> do + submitJob mods ghAccessTokenM (FlakeRef uri) = withEvent (modifyEventBackend mods backend) SubmitJob \ev -> do addField ev $ SubmittedRef uri jobId <- nextRandom diff --git a/src/Plutus/Certification/Server/Instance.hs b/src/Plutus/Certification/Server/Instance.hs index 3d5ddc81..cb645212 100644 --- a/src/Plutus/Certification/Server/Instance.hs +++ b/src/Plutus/Certification/Server/Instance.hs @@ -45,7 +45,7 @@ import qualified Plutus.Certification.Web3StorageClient as IPFS hoistServerCaps :: (Monad m) => (forall x . m x -> n x) -> ServerCaps m r -> ServerCaps n r hoistServerCaps nt (ServerCaps {..}) = ServerCaps - { submitJob = \mods -> nt . submitJob mods + { submitJob = \mods ghAccessTokenM -> nt . submitJob mods ghAccessTokenM , getRuns = \mods -> transPipe nt . getRuns mods , abortRuns = \mods -> nt . abortRuns mods , getLogs = \mods act -> transPipe nt . getLogs mods act @@ -70,11 +70,12 @@ server ServerCaps {..} ServerArgs{..} eb = NamedAPI , versionHead = withEvent eb Version . const $ pure NoContent , walletAddress = withEvent eb WalletAddress . const $ pure walletArgs.walletAddress , createRun = \(profileId,_) commitOrBranch -> withEvent eb CreateRun \ev -> do - fref <- getFlakeRef profileId commitOrBranch + (fref,profileAccessToken) <- getFlakeRefAndAccessToken profileId commitOrBranch + let githubToken' = profileAccessToken <|> githubToken -- ensure the ref is in the right format before start the job (commitDate,commitHash) <- getCommitDateAndHash fref addField ev $ CreateRunRef fref - res <- submitJob (setAncestor $ reference ev) fref + res <- submitJob (setAncestor $ reference ev) githubToken' fref addField ev $ CreateRunID res createDbRun fref profileId res commitDate commitHash pure res @@ -119,7 +120,10 @@ server ServerCaps {..} ServerArgs{..} eb = NamedAPI DB.withDb $ DB.getRuns profileId afterM countM , updateCurrentProfile = \(profileId,UserAddress ownerAddress) ProfileBody{..} -> do let dappId = profileId - let dappM = fmap (\DAppBody{..} -> DB.DApp{..}) dapp + let dappM = fmap (\DAppBody{..} -> DB.DApp{ + dappId, dappName,dappOwner,dappVersion,dappRepo, + dappGitHubToken = fmap (ghAccessTokenToText . unApiGitHubAccessToken) dappGitHubToken + }) dapp DB.withDb $ do _ <- DB.upsertProfile (DB.Profile{..}) dappM -- it's safe to call partial function fromJust @@ -170,8 +174,7 @@ server ServerCaps {..} ServerArgs{..} eb = NamedAPI , getRepositoryInfo = \owner repo apiGhAccessTokenM -> withEvent eb GetRepoInfo \ev -> do addField ev (GetRepoInfoOwner owner) addField ev (GetRepoInfoRepo repo) - let ghAccessTokenM = GitHubAccessToken . unApiGitHubAccessToken - <$> apiGhAccessTokenM + let ghAccessTokenM = unApiGitHubAccessToken <$> apiGhAccessTokenM -- if there is no github access token, we use the default one -- provided from arguments ghAccessTokenM' = ghAccessTokenM <|> githubToken @@ -213,7 +216,7 @@ server ServerCaps {..} ServerArgs{..} eb = NamedAPI _ <- dbSync uuid status pure run - getFlakeRef profileId commitOrBranch = + getFlakeRefAndAccessToken profileId commitOrBranch = getProfileDApp profileId >>= flip createFlakeRef commitOrBranch eitherToServerError baseHttpError f = either @@ -229,9 +232,10 @@ server ServerCaps {..} ServerArgs{..} eb = NamedAPI $ forbidden "DApp owner or repo are empty" let uri = "github:" <> encodeUtf8 dappOwner <> "/" <> encodeUtf8 dappRepo <> "/" <> encodeUtf8 commitOrBranch - eitherToServerError + fref <- eitherToServerError err400 LSB.pack (mimeUnrender (Proxy :: Proxy PlainText) (LSB.fromStrict uri)) + pure (fref,knownGhAccessTokenFromText <$> dappGitHubToken) forbidden str = throwError $ err403 { errBody = str} diff --git a/src/Plutus/Certification/Server/Internal.hs b/src/Plutus/Certification/Server/Internal.hs index a00c4ca0..fc47994c 100644 --- a/src/Plutus/Certification/Server/Internal.hs +++ b/src/Plutus/Certification/Server/Internal.hs @@ -31,7 +31,7 @@ import qualified IOHK.Certification.Persistence as DB -- | Capabilities needed to run a server for 'API' data ServerCaps m r = ServerCaps { -- | Submit a new certification job - submitJob :: !(EventBackendModifiers r r -> FlakeRefV1 -> m RunIDV1) + submitJob :: !(EventBackendModifiers r r -> Maybe GitHubAccessToken -> FlakeRefV1 -> m RunIDV1) , -- | Get the status of all runs associated with a job getRuns :: !(EventBackendModifiers r r -> RunIDV1 -> ConduitT () RunStatusV1 m ()) , -- | Delete all runs associated with a job From f4851573e5648026e39581ad0e1f495b18f96124 Mon Sep 17 00:00:00 2001 From: Bogdan Manole Date: Tue, 21 Feb 2023 00:03:02 +0000 Subject: [PATCH 3/5] fix: change gh-access-token from env var to arg: (DAC-484) --- .../src/IOHK/Certification/Actions.hs | 49 ++++++++----------- 1 file changed, 21 insertions(+), 28 deletions(-) diff --git a/dapps-certification-helpers/src/IOHK/Certification/Actions.hs b/dapps-certification-helpers/src/IOHK/Certification/Actions.hs index a8d1481e..5cdf621e 100644 --- a/dapps-certification-helpers/src/IOHK/Certification/Actions.hs +++ b/dapps-certification-helpers/src/IOHK/Certification/Actions.hs @@ -18,7 +18,6 @@ import Control.Monad.IO.Unlift import Data.Aeson.Internal as Aeson import Data.Aeson.Types as Aeson import Data.Aeson.Text as Aeson -import Data.Function import Data.Time.Clock.POSIX import Data.Text as T import Data.Text.IO hiding (putStrLn) @@ -104,13 +103,13 @@ buildFlake backend addLogEntry ghAccessTokenM dir = do Nothing -> throw $ MissingOut drvPath Right (_ :| tl) -> throw . ExtraBuilds $ L.length tl where - cmd = proc "nix" [ "build" - , "--refresh" - , "path:" ++ dir - , "--no-link" - , "--json" - , "--print-build-logs" - ] & setGitHubAccessToken ghAccessTokenM + cmd = proc "nix" $ [ "build" + , "--refresh" + , "path:" ++ dir + , "--no-link" + , "--json" + , "--print-build-logs" + ] ++ accessTokenToArg ghAccessTokenM runCertify :: (Text -> IO ()) -> FilePath -> ConduitT () Message ResIO () runCertify addLogEntry certify = do @@ -181,14 +180,14 @@ decodeFlakeLock = iparse $ withObject "flake-metadata" \o -> do flip (withObject "flake-lock") lock \o' -> do ty <- o' .: "type" when (ty /= ghTy) $ - parserThrowError [ (Key "locked"), (Key "type") ] ("invalid flake type " ++ show ty) + parserThrowError [ Key "locked", Key "type" ] ("invalid flake type " ++ show ty) lastModified <- o' .: "lastModified" narHash <- o' .: "narHash" owner <- o' .: "owner" repo <- o' .: "repo" - rev <- o' .: "rev" >>= decodeRev [ (Key "locked"), (Key "rev") ] + rev <- o' .: "rev" >>= decodeRev [ Key "locked", Key "rev" ] pure $ FlakeLock { gitHubFlake = GitHubFlakeLock {..} , .. @@ -200,9 +199,9 @@ decodeFlakeLock = iparse $ withObject "flake-metadata" \o -> do decodeRev :: JSONPath -> Text -> Aeson.Parser SHA1Hash decodeRev path r = case parseSHA1Hash r of Left (NotBase16 msg) -> - parserThrowError path $ "rev " ++ (show r) ++ " is not valid base16: " ++ (show msg) + parserThrowError path $ "rev " ++ show r ++ " is not valid base16: " ++ show msg Left (BadLength len) -> - parserThrowError path $ "rev " ++ (show r) ++ " is a base16 string representing " ++ (show len) ++ " bytes, expecting 20" + parserThrowError path $ "rev " ++ show r ++ " is a base16 string representing " ++ show len ++ " bytes, expecting 20" Right h -> pure h logHandleText :: (MonadUnliftIO m) @@ -296,22 +295,16 @@ lockRef backend ghAccessTokenM flakeref = withEvent backend LockingFlake \ev -> addField ev $ LockingLock lock pure lock where - cmd = proc "nix" [ "flake" - , "--refresh" - , "metadata" - , "--no-update-lock-file" - , "--json" - , uriToString id flakeref "" - ] & setGitHubAccessToken ghAccessTokenM - -setGitHubAccessToken :: Maybe GitHubAccessToken - -> ProcessConfig stdin stdout stderr - -> ProcessConfig stdin stdout stderr -setGitHubAccessToken Nothing = id -setGitHubAccessToken (Just ghAccessToken) = - let token = ghAccessTokenToText ghAccessToken - var = "access-tokens = github.com=" <> T.unpack token - in setEnv [("NIX_CONFIG", var)] + cmd = proc "nix" $ [ "flake" + , "--refresh" + , "metadata" + , "--no-update-lock-file" + , "--json" + , uriToString id flakeref "" + ] ++ accessTokenToArg ghAccessTokenM + +accessTokenToArg :: Maybe GitHubAccessToken -> [[Char]] +accessTokenToArg = maybe [] \token -> ["--access-tokens", "github.com="++ T.unpack (ghAccessTokenToText token)] gitHubAccessTokenReader :: ReadM GitHubAccessToken gitHubAccessTokenReader = do From 0e5e6699b5fae60bd79ab3248d58601c85a83049 Mon Sep 17 00:00:00 2001 From: Bogdan Manole Date: Wed, 22 Feb 2023 02:55:25 +0200 Subject: [PATCH 4/5] feat: add support for gh-access-token in Cicero (DAC-484) --- src/Plutus/Certification/Cicero.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Plutus/Certification/Cicero.hs b/src/Plutus/Certification/Cicero.hs index 6c85a381..8b01547b 100644 --- a/src/Plutus/Certification/Cicero.hs +++ b/src/Plutus/Certification/Cicero.hs @@ -50,6 +50,7 @@ import Plutus.Certification.API import Plutus.Certification.Cache import Plutus.Certification.Client import Plutus.Certification.Server +import IOHK.Certification.Interface (ghAccessTokenToText) ciceroClient :: forall m . HasClient m Cicero.API => Client m Cicero.API ciceroClient = cicero `clientIn` m @@ -83,12 +84,16 @@ data CiceroCaps c m r = CiceroCaps ciceroServerCaps :: forall c m r . (MonadMask m, HasClient c Cicero.API) => EventBackend m r RunClientSelector -> CiceroCaps c m r -> ServerCaps m r ciceroServerCaps backend CiceroCaps {..} = ServerCaps {..} where - submitJob mods _ ref = RunID . (.id.uuid) <$> runClientOrDie clientCaps backend' req + submitJob mods ghAccessTokenM ref = RunID . (.id.uuid) <$> runClientOrDie clientCaps backend' req where backend' = modifyEventBackend mods backend uri = ref.uri -- aesonQQ's parser doesn't support RecordDot yet + textGhAccessTokenM = fmap ghAccessTokenToText ghAccessTokenM req = ciceroClient.fact.create $ Cicero.Fact.CreateFact - { fact = [aesonQQ| { "plutus-certification/generate-flake": { "ref": #{uriToString id uri ""} } } |] + { fact = [aesonQQ| { "plutus-certification/generate-flake": + { "ref": #{uriToString id uri ""} + , "ghAccessToken": #{textGhAccessTokenM} + } } |] , artifact = Nothing } From e3d39f43473134ad69d2274ed4dcaaef91c607f2 Mon Sep 17 00:00:00 2001 From: Bogdan Manole Date: Wed, 22 Feb 2023 23:33:35 +0000 Subject: [PATCH 5/5] fix: redact access token from logs (DAC-484) --- .../dapps-certification-helpers.cabal | 1 + .../src/IOHK/Certification/Actions.hs | 117 ++++++++++-------- .../Certification/Persistence/Structure.hs | 2 +- .../.plan.nix/dapps-certification-helpers.nix | 1 + nix/materialized/aarch64-darwin/default.nix | 7 ++ .../.plan.nix/dapps-certification-helpers.nix | 1 + nix/materialized/x86_64-darwin/default.nix | 7 ++ .../.plan.nix/dapps-certification-helpers.nix | 1 + nix/materialized/x86_64-linux/default.nix | 7 ++ src/Plutus/Certification/API/Routes.hs | 5 +- 10 files changed, 90 insertions(+), 59 deletions(-) diff --git a/dapps-certification-helpers/dapps-certification-helpers.cabal b/dapps-certification-helpers/dapps-certification-helpers.cabal index 06ef133d..61eff191 100644 --- a/dapps-certification-helpers/dapps-certification-helpers.cabal +++ b/dapps-certification-helpers/dapps-certification-helpers.cabal @@ -29,6 +29,7 @@ library conduit, conduit-aeson, optparse-applicative, + regex-compat, dapps-certification-interface hs-source-dirs: src other-modules: Paths_dapps_certification_helpers diff --git a/dapps-certification-helpers/src/IOHK/Certification/Actions.hs b/dapps-certification-helpers/src/IOHK/Certification/Actions.hs index 5cdf621e..86e13473 100644 --- a/dapps-certification-helpers/src/IOHK/Certification/Actions.hs +++ b/dapps-certification-helpers/src/IOHK/Certification/Actions.hs @@ -1,53 +1,55 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} module IOHK.Certification.Actions where -import Data.Coerce -import Paths_dapps_certification_helpers -import System.Directory -import Network.URI hiding (path) -import Control.Exception -import Control.Concurrent.Async -import Control.Monad.IO.Unlift -import Data.Aeson.Internal as Aeson -import Data.Aeson.Types as Aeson -import Data.Aeson.Text as Aeson -import Data.Time.Clock.POSIX -import Data.Text as T -import Data.Text.IO hiding (putStrLn) -import Data.Text.Encoding -import Data.ByteString as BS hiding (hPutStr) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Internal as LBS -import qualified Data.Text.Lazy as LT -import Data.ByteString.Base16 -import System.Process.Typed -import System.Process (Pid, getPid) -import Data.Aeson.Parser -import Data.Aeson.Parser.Internal -import Observe.Event -import Observe.Event.Render.JSON -import Data.Void -import System.IO hiding (hPutStrLn, hPutStr) -import System.FilePath -import Control.Monad -import Control.Monad.Catch hiding (finally) -import Data.List.NonEmpty -import Data.Map as Map -import qualified Data.Vector as V -import Data.List as L -import Data.Acquire -import Control.Monad.Trans.Resource -import IOHK.Certification.Interface hiding (Success) -import Conduit -import Data.Conduit.Aeson -import Options.Applicative as Optparse +import Conduit +import Control.Concurrent.Async +import Control.Exception +import Control.Monad +import Control.Monad.Catch hiding (finally) +import Control.Monad.Trans.Resource +import Data.Acquire +import Data.Aeson.Internal as Aeson +import Data.Aeson.Parser +import Data.Aeson.Parser.Internal +import Data.Aeson.Text as Aeson +import Data.Aeson.Types as Aeson +import Data.ByteString as BS hiding (hPutStr) +import Data.ByteString.Base16 +import Data.Coerce +import Data.Conduit.Aeson +import Data.List as L +import Data.List.NonEmpty +import Data.Map as Map +import Data.Text as T +import Data.Text.Encoding +import Data.Text.IO hiding (putStrLn) +import Data.Time.Clock.POSIX +import Data.Void +import IOHK.Certification.Interface hiding (Success) +import Network.URI hiding (path) +import Observe.Event +import Observe.Event.Render.JSON +import Options.Applicative as Optparse +import Paths_dapps_certification_helpers +import System.Directory +import System.FilePath +import System.IO hiding (hPutStr, hPutStrLn) +import System.Process (Pid, getPid) +import System.Process.Typed +import Text.Regex + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Internal as LBS +import qualified Data.Text.Lazy as LT +import qualified Data.Vector as V + generateFlake :: EventBackend IO r GenerateFlakeSelector -> (Text -> IO ()) -> Maybe GitHubAccessToken -> URI -> FilePath -> IO () generateFlake backend addLogEntry ghAccessTokenM flakeref output = withEvent backend GenerateFlake \ev -> do @@ -99,7 +101,7 @@ buildFlake backend addLogEntry ghAccessTokenM dir = do case eitherDecodeWith jsonEOF decodeBuild buildJson of Left (path, err) -> throw $ DecodeBuild path err Right (BuildResult {..} :| []) -> case Map.lookup "out" outputs of - Just p -> pure p + Just p -> pure p Nothing -> throw $ MissingOut drvPath Right (_ :| tl) -> throw . ExtraBuilds $ L.length tl where @@ -134,7 +136,7 @@ acquireProcessWait :: ProcessConfig i o e -> Acquire (Process i o e) acquireProcessWait cfg = mkAcquireType (startProcess cfg) cleanup where cleanup p ReleaseException = stopProcess p - cleanup p _ = finally (checkExitCode p) (stopProcess p) + cleanup p _ = finally (checkExitCode p) (stopProcess p) newtype SHA1Hash = SHA1Hash ByteString @@ -151,14 +153,14 @@ renderSHA1Hash = encodeBase16 . coerce data GitHubFlakeLock = GitHubFlakeLock { owner :: !Text - , repo :: !Text - , rev :: !SHA1Hash + , repo :: !Text + , rev :: !SHA1Hash } data FlakeLock = FlakeLock { lastModified :: !POSIXTime - , narHash :: !Text -- Sigh https://github.com/haskell-crypto/cryptonite/issues/337 - , gitHubFlake :: !GitHubFlakeLock -- Assuming GH only for now... + , narHash :: !Text -- Sigh https://github.com/haskell-crypto/cryptonite/issues/337 + , gitHubFlake :: !GitHubFlakeLock -- Assuming GH only for now... } writeNix :: Handle -> FlakeLock -> IO () @@ -361,8 +363,13 @@ data LaunchField = forall stdin stdoutIgnored stderrIgnored . LaunchConfig !(ProcessConfig stdin stdoutIgnored stderrIgnored) | LaunchingPid !Pid +ghAccessFlexibleTokenPattern = "gh[oprst]_[A-Za-z0-9]+" + renderLaunchField :: RenderFieldJSON LaunchField -renderLaunchField (LaunchConfig cfg) = ("launch-config", toJSON $ show cfg) +renderLaunchField (LaunchConfig cfg) = ("launch-config", toJSON redactedCfgString) + where + redactGitHubAccess = subRegex (mkRegex ghAccessFlexibleTokenPattern) + redactedCfgString = redactGitHubAccess (show cfg) "<>" renderLaunchField (LaunchingPid pid) = ("launched-pid", toJSON $ toInteger pid) data LogHandleSelector f where @@ -473,7 +480,7 @@ instance ToJSON LockException where ) renderElement :: JSONPathElement -> Value -renderElement (Key k) = object [ "key" .= k ] +renderElement (Key k) = object [ "key" .= k ] renderElement (Index i) = object [ "index" .= i ] instance Exception LockException where diff --git a/dapps-certification-persistence/src/IOHK/Certification/Persistence/Structure.hs b/dapps-certification-persistence/src/IOHK/Certification/Persistence/Structure.hs index 315617a8..981726d3 100644 --- a/dapps-certification-persistence/src/IOHK/Certification/Persistence/Structure.hs +++ b/dapps-certification-persistence/src/IOHK/Certification/Persistence/Structure.hs @@ -161,7 +161,7 @@ instance ToJSON DApp where , "owner" .= dappOwner , "repo" .= dappRepo , "version" .= dappVersion - , "githubToken" .= dappGitHubToken + , "githubToken" .= fmap (const ("<>" :: Text)) dappGitHubToken ] instance SqlRow DApp diff --git a/nix/materialized/aarch64-darwin/.plan.nix/dapps-certification-helpers.nix b/nix/materialized/aarch64-darwin/.plan.nix/dapps-certification-helpers.nix index e2fc5d43..a8c918fa 100644 --- a/nix/materialized/aarch64-darwin/.plan.nix/dapps-certification-helpers.nix +++ b/nix/materialized/aarch64-darwin/.plan.nix/dapps-certification-helpers.nix @@ -57,6 +57,7 @@ (hsPkgs."conduit" or (errorHandler.buildDepError "conduit")) (hsPkgs."conduit-aeson" or (errorHandler.buildDepError "conduit-aeson")) (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) + (hsPkgs."regex-compat" or (errorHandler.buildDepError "regex-compat")) (hsPkgs."dapps-certification-interface" or (errorHandler.buildDepError "dapps-certification-interface")) ]; buildable = true; diff --git a/nix/materialized/aarch64-darwin/default.nix b/nix/materialized/aarch64-darwin/default.nix index 331d866a..025434b8 100644 --- a/nix/materialized/aarch64-darwin/default.nix +++ b/nix/materialized/aarch64-darwin/default.nix @@ -14,6 +14,8 @@ "pretty".revision = (((hackage."pretty")."1.1.3.6").revisions).default; "haskell-src-exts".revision = (((hackage."haskell-src-exts")."1.23.1").revisions).default; "data-textual".revision = (((hackage."data-textual")."0.3.0.3").revisions).default; + "regex-posix".revision = (((hackage."regex-posix")."0.96.0.1").revisions).default; + "regex-posix".flags._regex-posix-clib = false; "servant-swagger-ui-core".revision = (((hackage."servant-swagger-ui-core")."0.3.5").revisions).default; "network-uri".revision = (((hackage."network-uri")."2.6.4.2").revisions).default; "parsers".revision = (((hackage."parsers")."0.12.11").revisions).default; @@ -163,6 +165,7 @@ "stm".revision = (((hackage."stm")."2.5.0.2").revisions).default; "void".revision = (((hackage."void")."0.7.3").revisions).default; "void".flags.safe = false; + "regex-compat".revision = (((hackage."regex-compat")."0.95.2.1").revisions).default; "semigroups".revision = (((hackage."semigroups")."0.20").revisions).default; "semigroups".flags.bytestring = true; "semigroups".flags.bytestring-builder = false; @@ -247,6 +250,7 @@ "transformers-base".flags.orphaninstances = true; "aeson-qq".revision = (((hackage."aeson-qq")."0.8.4").revisions).default; "data-default-class".revision = (((hackage."data-default-class")."0.1.2.0").revisions).default; + "regex-base".revision = (((hackage."regex-base")."0.94.0.2").revisions).default; "vector-algorithms".revision = (((hackage."vector-algorithms")."0.9.0.1").revisions).default; "vector-algorithms".flags.internalchecks = false; "vector-algorithms".flags.llvm = false; @@ -523,6 +527,7 @@ "servant-server".components.library.planned = lib.mkOverride 900 true; "data-default-class".components.library.planned = lib.mkOverride 900 true; "type-hint".components.library.planned = lib.mkOverride 900 true; + "regex-base".components.library.planned = lib.mkOverride 900 true; "adjunctions".components.library.planned = lib.mkOverride 900 true; "parallel".components.library.planned = lib.mkOverride 900 true; "cryptonite".components.library.planned = lib.mkOverride 900 true; @@ -573,6 +578,7 @@ "network-uri".components.library.planned = lib.mkOverride 900 true; "lzma".components.library.planned = lib.mkOverride 900 true; "wai-logger".components.setup.planned = lib.mkOverride 900 true; + "regex-posix".components.library.planned = lib.mkOverride 900 true; "data-serializer".components.library.planned = lib.mkOverride 900 true; "memory".components.library.planned = lib.mkOverride 900 true; "pem".components.library.planned = lib.mkOverride 900 true; @@ -693,6 +699,7 @@ "warp".components.library.planned = lib.mkOverride 900 true; "easy-file".components.library.planned = lib.mkOverride 900 true; "base16".components.library.planned = lib.mkOverride 900 true; + "regex-compat".components.library.planned = lib.mkOverride 900 true; "swagger2".components.library.planned = lib.mkOverride 900 true; "conduit-extra".components.library.planned = lib.mkOverride 900 true; "terminfo".components.library.planned = lib.mkOverride 900 true; diff --git a/nix/materialized/x86_64-darwin/.plan.nix/dapps-certification-helpers.nix b/nix/materialized/x86_64-darwin/.plan.nix/dapps-certification-helpers.nix index e2fc5d43..a8c918fa 100644 --- a/nix/materialized/x86_64-darwin/.plan.nix/dapps-certification-helpers.nix +++ b/nix/materialized/x86_64-darwin/.plan.nix/dapps-certification-helpers.nix @@ -57,6 +57,7 @@ (hsPkgs."conduit" or (errorHandler.buildDepError "conduit")) (hsPkgs."conduit-aeson" or (errorHandler.buildDepError "conduit-aeson")) (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) + (hsPkgs."regex-compat" or (errorHandler.buildDepError "regex-compat")) (hsPkgs."dapps-certification-interface" or (errorHandler.buildDepError "dapps-certification-interface")) ]; buildable = true; diff --git a/nix/materialized/x86_64-darwin/default.nix b/nix/materialized/x86_64-darwin/default.nix index 331d866a..025434b8 100644 --- a/nix/materialized/x86_64-darwin/default.nix +++ b/nix/materialized/x86_64-darwin/default.nix @@ -14,6 +14,8 @@ "pretty".revision = (((hackage."pretty")."1.1.3.6").revisions).default; "haskell-src-exts".revision = (((hackage."haskell-src-exts")."1.23.1").revisions).default; "data-textual".revision = (((hackage."data-textual")."0.3.0.3").revisions).default; + "regex-posix".revision = (((hackage."regex-posix")."0.96.0.1").revisions).default; + "regex-posix".flags._regex-posix-clib = false; "servant-swagger-ui-core".revision = (((hackage."servant-swagger-ui-core")."0.3.5").revisions).default; "network-uri".revision = (((hackage."network-uri")."2.6.4.2").revisions).default; "parsers".revision = (((hackage."parsers")."0.12.11").revisions).default; @@ -163,6 +165,7 @@ "stm".revision = (((hackage."stm")."2.5.0.2").revisions).default; "void".revision = (((hackage."void")."0.7.3").revisions).default; "void".flags.safe = false; + "regex-compat".revision = (((hackage."regex-compat")."0.95.2.1").revisions).default; "semigroups".revision = (((hackage."semigroups")."0.20").revisions).default; "semigroups".flags.bytestring = true; "semigroups".flags.bytestring-builder = false; @@ -247,6 +250,7 @@ "transformers-base".flags.orphaninstances = true; "aeson-qq".revision = (((hackage."aeson-qq")."0.8.4").revisions).default; "data-default-class".revision = (((hackage."data-default-class")."0.1.2.0").revisions).default; + "regex-base".revision = (((hackage."regex-base")."0.94.0.2").revisions).default; "vector-algorithms".revision = (((hackage."vector-algorithms")."0.9.0.1").revisions).default; "vector-algorithms".flags.internalchecks = false; "vector-algorithms".flags.llvm = false; @@ -523,6 +527,7 @@ "servant-server".components.library.planned = lib.mkOverride 900 true; "data-default-class".components.library.planned = lib.mkOverride 900 true; "type-hint".components.library.planned = lib.mkOverride 900 true; + "regex-base".components.library.planned = lib.mkOverride 900 true; "adjunctions".components.library.planned = lib.mkOverride 900 true; "parallel".components.library.planned = lib.mkOverride 900 true; "cryptonite".components.library.planned = lib.mkOverride 900 true; @@ -573,6 +578,7 @@ "network-uri".components.library.planned = lib.mkOverride 900 true; "lzma".components.library.planned = lib.mkOverride 900 true; "wai-logger".components.setup.planned = lib.mkOverride 900 true; + "regex-posix".components.library.planned = lib.mkOverride 900 true; "data-serializer".components.library.planned = lib.mkOverride 900 true; "memory".components.library.planned = lib.mkOverride 900 true; "pem".components.library.planned = lib.mkOverride 900 true; @@ -693,6 +699,7 @@ "warp".components.library.planned = lib.mkOverride 900 true; "easy-file".components.library.planned = lib.mkOverride 900 true; "base16".components.library.planned = lib.mkOverride 900 true; + "regex-compat".components.library.planned = lib.mkOverride 900 true; "swagger2".components.library.planned = lib.mkOverride 900 true; "conduit-extra".components.library.planned = lib.mkOverride 900 true; "terminfo".components.library.planned = lib.mkOverride 900 true; diff --git a/nix/materialized/x86_64-linux/.plan.nix/dapps-certification-helpers.nix b/nix/materialized/x86_64-linux/.plan.nix/dapps-certification-helpers.nix index e2fc5d43..a8c918fa 100644 --- a/nix/materialized/x86_64-linux/.plan.nix/dapps-certification-helpers.nix +++ b/nix/materialized/x86_64-linux/.plan.nix/dapps-certification-helpers.nix @@ -57,6 +57,7 @@ (hsPkgs."conduit" or (errorHandler.buildDepError "conduit")) (hsPkgs."conduit-aeson" or (errorHandler.buildDepError "conduit-aeson")) (hsPkgs."optparse-applicative" or (errorHandler.buildDepError "optparse-applicative")) + (hsPkgs."regex-compat" or (errorHandler.buildDepError "regex-compat")) (hsPkgs."dapps-certification-interface" or (errorHandler.buildDepError "dapps-certification-interface")) ]; buildable = true; diff --git a/nix/materialized/x86_64-linux/default.nix b/nix/materialized/x86_64-linux/default.nix index 331d866a..025434b8 100644 --- a/nix/materialized/x86_64-linux/default.nix +++ b/nix/materialized/x86_64-linux/default.nix @@ -14,6 +14,8 @@ "pretty".revision = (((hackage."pretty")."1.1.3.6").revisions).default; "haskell-src-exts".revision = (((hackage."haskell-src-exts")."1.23.1").revisions).default; "data-textual".revision = (((hackage."data-textual")."0.3.0.3").revisions).default; + "regex-posix".revision = (((hackage."regex-posix")."0.96.0.1").revisions).default; + "regex-posix".flags._regex-posix-clib = false; "servant-swagger-ui-core".revision = (((hackage."servant-swagger-ui-core")."0.3.5").revisions).default; "network-uri".revision = (((hackage."network-uri")."2.6.4.2").revisions).default; "parsers".revision = (((hackage."parsers")."0.12.11").revisions).default; @@ -163,6 +165,7 @@ "stm".revision = (((hackage."stm")."2.5.0.2").revisions).default; "void".revision = (((hackage."void")."0.7.3").revisions).default; "void".flags.safe = false; + "regex-compat".revision = (((hackage."regex-compat")."0.95.2.1").revisions).default; "semigroups".revision = (((hackage."semigroups")."0.20").revisions).default; "semigroups".flags.bytestring = true; "semigroups".flags.bytestring-builder = false; @@ -247,6 +250,7 @@ "transformers-base".flags.orphaninstances = true; "aeson-qq".revision = (((hackage."aeson-qq")."0.8.4").revisions).default; "data-default-class".revision = (((hackage."data-default-class")."0.1.2.0").revisions).default; + "regex-base".revision = (((hackage."regex-base")."0.94.0.2").revisions).default; "vector-algorithms".revision = (((hackage."vector-algorithms")."0.9.0.1").revisions).default; "vector-algorithms".flags.internalchecks = false; "vector-algorithms".flags.llvm = false; @@ -523,6 +527,7 @@ "servant-server".components.library.planned = lib.mkOverride 900 true; "data-default-class".components.library.planned = lib.mkOverride 900 true; "type-hint".components.library.planned = lib.mkOverride 900 true; + "regex-base".components.library.planned = lib.mkOverride 900 true; "adjunctions".components.library.planned = lib.mkOverride 900 true; "parallel".components.library.planned = lib.mkOverride 900 true; "cryptonite".components.library.planned = lib.mkOverride 900 true; @@ -573,6 +578,7 @@ "network-uri".components.library.planned = lib.mkOverride 900 true; "lzma".components.library.planned = lib.mkOverride 900 true; "wai-logger".components.setup.planned = lib.mkOverride 900 true; + "regex-posix".components.library.planned = lib.mkOverride 900 true; "data-serializer".components.library.planned = lib.mkOverride 900 true; "memory".components.library.planned = lib.mkOverride 900 true; "pem".components.library.planned = lib.mkOverride 900 true; @@ -693,6 +699,7 @@ "warp".components.library.planned = lib.mkOverride 900 true; "easy-file".components.library.planned = lib.mkOverride 900 true; "base16".components.library.planned = lib.mkOverride 900 true; + "regex-compat".components.library.planned = lib.mkOverride 900 true; "swagger2".components.library.planned = lib.mkOverride 900 true; "conduit-extra".components.library.planned = lib.mkOverride 900 true; "terminfo".components.library.planned = lib.mkOverride 900 true; diff --git a/src/Plutus/Certification/API/Routes.hs b/src/Plutus/Certification/API/Routes.hs index bd7ed7e5..445e498e 100644 --- a/src/Plutus/Certification/API/Routes.hs +++ b/src/Plutus/Certification/API/Routes.hs @@ -142,11 +142,10 @@ instance ToJSON ApiGitHubAccessToken where toJSON = toJSON . ghAccessTokenToText . unApiGitHubAccessToken instance FromJSON ApiGitHubAccessToken where - parseJSON = withObject "ApiGitHubAccessToken" $ \o -> do - token <- o .: "token" + parseJSON = withText "ApiGitHubAccessToken" $ \token -> case ghAccessTokenFromText token of Left err -> fail err - Right t -> pure $ ApiGitHubAccessToken t + Right t -> pure $ ApiGitHubAccessToken t instance ToHttpApiData ApiGitHubAccessToken where -- | Convert a 'GitHubAccessToken' to a 'Text' value.