Add repository storage support

Signed-off-by: Sascha Grunert <mail@saschagrunert.de>

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:

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 = [

package.yaml

@@ -56,6 +56,7 @@ library:
   source-dirs: src
   dependencies:
     - ansi-terminal
+    - base64-bytestring
     - bytestring
     - github
     - hslogger

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

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"

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 results"
+                                    , 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"
+

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