From dc95d78cf6ff2531db96b844cf3f7ee3e1b17b4d Mon Sep 17 00:00:00 2001 From: Sascha Grunert Date: Sat, 29 Jun 2019 16:54:24 +0200 Subject: [PATCH] Add repository storage support (#34) Signed-off-by: Sascha Grunert --- README.md | 11 ++-- nix/default.nix | 10 ++-- package.yaml | 1 + performabot.cabal | 4 +- src/Default.hs | 14 +++++ src/Github.hs | 150 ++++++++++++++++++++++++++++++++++++++++++++-- src/Result.hs | 17 +++--- 7 files changed, 183 insertions(+), 24 deletions(-) create mode 100644 src/Default.hs diff --git a/README.md b/README.md index 25f8488..8786ecf 100644 --- a/README.md +++ b/README.md @@ -13,11 +13,12 @@ performance benchmarks are supported. ## How it works Performabot parses the output of a micro-benchmarking framework. After the -successful parsing it puts the data into a local -[SQLite](https://www.sqlite.org) database. This database is named -`performabot.sqlite`, where multiple consecutive test runs will result in -reusing that database. If Performabot finds data where it can compare the -current run against, then it will do that as well. +successful parsing it puts the data into a new GitHub repository called +`performabot-results`. This repository is automatically created by the user +who owns the specified token. All data within that repository will be managed by +performabot, whereas data updates result in additional commits within that +repository. If Performabot finds data where it can compare the current run +against, then it will do that as well. Performabot updates the corresponding GitHub pull request after the run with a comment which contains all necessary information, like these: diff --git a/nix/default.nix b/nix/default.nix index dc46fa6..6688b70 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -1,5 +1,5 @@ -{ mkDerivation, ansi-terminal, base, bytestring, github, hpack -, hslogger, lens, megaparsec, optparse-applicative +{ mkDerivation, ansi-terminal, base, base64-bytestring, bytestring +, github, hpack, hslogger, lens, megaparsec, optparse-applicative , parser-combinators, persistent, persistent-sqlite , persistent-template, stdenv, tasty, tasty-hspec, tasty-quickcheck , text, time, vector @@ -11,9 +11,9 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - ansi-terminal base bytestring github hslogger lens megaparsec - parser-combinators persistent persistent-sqlite persistent-template - text time vector + ansi-terminal base base64-bytestring bytestring github hslogger + lens megaparsec parser-combinators persistent persistent-sqlite + persistent-template text time vector ]; libraryToolDepends = [ hpack ]; executableHaskellDepends = [ diff --git a/package.yaml b/package.yaml index ba08bbf..02622c8 100644 --- a/package.yaml +++ b/package.yaml @@ -56,6 +56,7 @@ library: source-dirs: src dependencies: - ansi-terminal + - base64-bytestring - bytestring - github - hslogger diff --git a/performabot.cabal b/performabot.cabal index 6eb5f9b..cceb326 100644 --- a/performabot.cabal +++ b/performabot.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: a475f7d00ba30f4d6c0ae33a24988e83878600b3f468fd64bba9f2488281705d +-- hash: e6e26f2f314098b27b861c22ca69a2dd6934a720876de857f2f7b3251cfc6eec name: performabot version: 0.1.0 @@ -30,6 +30,7 @@ flag static library exposed-modules: + Default Environment Github Log @@ -47,6 +48,7 @@ library build-depends: ansi-terminal , base + , base64-bytestring , bytestring , github , hslogger diff --git a/src/Default.hs b/src/Default.hs new file mode 100644 index 0000000..00a4ee7 --- /dev/null +++ b/src/Default.hs @@ -0,0 +1,14 @@ +-- | Default data and paths +-- +-- @since 0.1.0 +module Default ( db, repo ) where + +import Data.Text ( Text ) + +-- | The database name +db :: Text +db = "performabot.sqlite" + +-- | The default repo name used for storage +repo :: Text +repo = "performabot-results" diff --git a/src/Github.hs b/src/Github.hs index ab1bd27..e15a5b5 100644 --- a/src/Github.hs +++ b/src/Github.hs @@ -1,33 +1,53 @@ -- | Github related actions -- -- @since 0.1.0 -module Github ( baseCommit, comment ) where +module Github ( baseCommit, comment, retrieveRemoteFile, updateRemoteFile ) where import Control.Lens ( (^.) ) -import Data.ByteString.Char8 as C ( pack ) +import Data.ByteString.Base64 as B ( decode, encode ) +import Data.ByteString.Char8 as C + ( pack, readFile, writeFile ) import Data.List ( find ) -import Data.Text as T ( Text, isInfixOf, pack ) +import Data.Text as T + ( Text, filter, isInfixOf, pack, unpack ) +import Data.Text.Encoding ( decodeUtf8, encodeUtf8 ) import Data.Vector ( Vector, toList ) +import Default ( db, repo ) + import Environment ( Environment, owner, pullRequest, repository, token ) import GitHub ( Auth(OAuth) ) import GitHub.Data.Comments ( Comment, commentHtmlUrl ) +import GitHub.Data.Content + ( Content(ContentFile), ContentFileData, CreateFile(CreateFile) + , UpdateFile(UpdateFile), contentFileContent, contentFileInfo + , contentSha, createFileAuthor, createFileBranch + , createFileCommitter, createFileContent, createFileMessage + , createFilePath, updateFileAuthor, updateFileBranch + , updateFileCommitter, updateFileContent, updateFileMessage + , updateFilePath, updateFileSHA ) import GitHub.Data.Definitions - ( Error, IssueNumber(IssueNumber), Owner ) + ( Error, IssueNumber(IssueNumber), Owner, simpleOwnerLogin ) import GitHub.Data.Id ( Id(Id) ) import GitHub.Data.Issues ( IssueComment, issueCommentBody, issueCommentId ) import GitHub.Data.Name ( Name(N) ) import GitHub.Data.PullRequests ( pullRequestBase, pullRequestCommitSha ) -import GitHub.Data.Repos ( Repo ) +import GitHub.Data.Repos + ( Repo, RepoPublicity(RepoPublicityOwner), newRepo, repoName + , repoOwner ) import GitHub.Data.URL ( getUrl ) import GitHub.Endpoints.Issues.Comments ( comments, createComment, editComment ) import GitHub.Endpoints.PullRequests ( pullRequest' ) +import GitHub.Endpoints.Repos + ( createRepo', currentUserRepos ) +import GitHub.Endpoints.Repos.Contents + ( contentsFor, createFile, updateFile ) import Log ( debug, err, notice ) @@ -84,7 +104,7 @@ handleCommentErr x t = case x of Right c -> notice $ printf "Comment %s successful: %s" t (urlOf $ commentHtmlUrl c) where - urlOf Nothing = "Not found." + urlOf Nothing = "Not found" urlOf (Just u) = getUrl u -- | Finds comments from performabot @@ -117,3 +137,121 @@ maybeInt s = case reads s of _ -> do err "Unable to parse pull request number" exitFailure + +-- | Update or create the remote database file +updateRemoteFile :: Environment -> (Either Error Content, Name Owner) -> IO () +updateRemoteFile e (contents, o) = do + file <- C.readFile $ T.unpack db + let b64Content = decodeUtf8 $ B.encode file + case contents of + Left _ -> createDatabaseFile (getAuth e) o b64Content + Right (ContentFile ff) -> + updateDatabaseFile (getAuth e) o b64Content ff + _ -> do + err "Wrong file type for database found remotely" + exitFailure + +-- | Download the remote databasefile if available +retrieveRemoteFile :: Environment -> IO (Either Error Content, Name Owner) +retrieveRemoteFile e = do + r <- createRepoIfNeeded $ getAuth e + let o = simpleOwnerLogin $ repoOwner r + contents <- contentsFor o defaultRepoName db Nothing + case contents of + Left _ -> do + notice "File does not exist remotely, skipping download" + return (contents, o) + Right (ContentFile f) -> do + notice "File download successful" + let content = B.decode . encodeUtf8 . T.filter (/= '\n') $ + contentFileContent f + case content of + Left fd -> do + err $ printf "Unable to decode retrieved bytestring: %s" fd + exitFailure + Right bs -> do + C.writeFile (T.unpack db) bs + notice "File successfully written to disk" + return (contents, o) + _ -> do + err "Wrong file type for database found remotely" + exitFailure + +-- | The default repo name used for data upload +defaultRepoName :: Name Repo +defaultRepoName = N repo + +-- | Create the default repository or simply retrieve it +createRepoIfNeeded :: Auth -> IO Repo +createRepoIfNeeded a = do + notice $ printf "Searching for default storage repository: %s" repo + repos <- currentUserRepos a RepoPublicityOwner + case repos of + Left f -> do + err "Unable to retrieve repositories" + debug $ show f + exitFailure + Right rs -> do + debug "Found repositories" + let repoExists = find (\x -> defaultRepoName == repoName x) + (toList rs) + case repoExists of + Nothing -> do + notice "Default repository does not seem to exist, creating it" + created <- createRepo' a (newRepo defaultRepoName) + case created of + Left f -> do + err "Unable to create new repository" + debug $ show f + exitFailure + Right r -> do + notice "Default repository created" + return r + Just r -> do + notice "Remote repo already exists" + return r + +-- | Create the file withinthe default repository +createDatabaseFile :: Auth -> Name Owner -> Text -> IO () +createDatabaseFile a o c = do + -- Create the file + notice "Unable to retrieve the database file, creating it" + create <- createFile a + o + defaultRepoName + CreateFile { createFilePath = db + , createFileMessage = "Create database" + , createFileContent = c + , createFileBranch = Nothing + , createFileAuthor = Nothing + , createFileCommitter = Nothing + } + case create of + Left f -> do + err "Unable to create database file" + debug $ show f + exitFailure + _ -> notice "File creation successful" + +-- | Update the file withinthe default repository +updateDatabaseFile :: Auth -> Name Owner -> Text -> ContentFileData -> IO () +updateDatabaseFile a o c f = do + update <- updateFile a + o + defaultRepoName + UpdateFile { updateFilePath = db + , updateFileMessage = "Update database" + , updateFileContent = c + , updateFileSHA = + contentSha $ contentFileInfo f + , updateFileBranch = Nothing + , updateFileAuthor = Nothing + , updateFileCommitter = Nothing + } + case update of + Left uf -> do + err "Unable to update database file" + debug $ show uf + exitFailure + _ -> notice "File update successful" + diff --git a/src/Result.hs b/src/Result.hs index 1223556..12fd9cf 100644 --- a/src/Result.hs +++ b/src/Result.hs @@ -13,10 +13,13 @@ import Database.Persist ( (<-.), (==.), SelectOpt(Asc, LimitTo) , entityVal, insert, selectList ) import Database.Persist.Sqlite ( runMigration, runSqlite ) +import Default ( db ) + import Environment ( Environment, commit, owner, pullRequest, repository ) -import Github ( baseCommit, comment ) +import Github + ( baseCommit, comment, retrieveRemoteFile, updateRemoteFile ) import Log ( debug, info, notice, noticeR ) @@ -74,25 +77,25 @@ debugResult r = debug . printf "Current result: %s" $ show r -- | Sen the provided data to the given url including the environment save :: Bool -> Step -> Environment -> IO () save l (_, b) e = do - insertInDB e b - info "Database insertion successful" r <- if not l then do + m <- retrieveRemoteFile e + insertInDB e b + notice $ printf "Database insertion successful in: %s" db c <- baseCommit e info "Base commit retrieval successful" pb <- entryForCommit c let r = prettyPrint b pb comment e r + updateRemoteFile e m return r else do notice "Local run specified" + insertInDB e b + notice $ printf "Database insertion successful in: %s" db return $ prettyPrint b Nothing notice $ printf "The report:\n\n%s" r --- | The database name -db :: Text -db = "performabot.sqlite" - -- | Insert the test into the database insertInDB :: Environment -> Benchmarks -> IO () insertInDB e b = runSqlite db $ do