From cde206eb235b2d012ff35aa763b949d4a5d99770 Mon Sep 17 00:00:00 2001 From: Sascha Grunert Date: Fri, 28 Jun 2019 09:31:41 +0200 Subject: [PATCH] Add github handling (#28) --- README.md | 31 +++++++++++ app/Main.hs | 17 +++--- nix/default.nix | 15 +++--- nix/nixpkgs.json | 6 +-- nix/overlay.nix | 28 ++++++++++ nix/release-static.nix | 4 +- nix/release.nix | 2 +- package.yaml | 6 +-- performabot.cabal | 14 ++--- src/Environment.hs | 55 ++++++++----------- src/Github.hs | 116 +++++++++++++++++++++++++++++++++++++++++ src/Model.hs | 30 ++--------- src/Pretty.hs | 92 ++++++++++++++++++++++++++++++++ src/Result.hs | 67 ++++++++++++++++++------ src/model | 7 +-- stack.yaml | 5 ++ 16 files changed, 390 insertions(+), 105 deletions(-) create mode 100644 nix/overlay.nix create mode 100644 src/Github.hs create mode 100644 src/Pretty.hs diff --git a/README.md b/README.md index 38e3a7a..a81f4bf 100644 --- a/README.md +++ b/README.md @@ -4,3 +4,34 @@ [![Coverage](https://coveralls.io/repos/github/saschagrunert/performabot/badge.svg?branch=master)](https://coveralls.io/github/saschagrunert/performabot?branch=master) [![Doc](https://img.shields.io/badge/doc-performabot-orange.svg)](https://saschagrunert.github.io/performabot) [![License MIT](https://img.shields.io/badge/license-MIT-blue.svg)](https://github.com/saschagrunert/performabot/blob/master/LICENSE) + +Welcome to performabot! This little helper can be used to provide Continuous +Performance Reports within your GitHub project. + +## How it works + +## Depdendencies + +There is only one dependency needed to get started with this project: +[nix](https://nixos.org/nix) + +To build the project, simply run: + +```shell +> make +``` + +If you need a shell where all build dependencies are already in `$PATH`, then +run: + +```shell +> make shell +``` + +There are other useful targets within the [Makefile](Makefile), which are used +by the CI and could be worth a look. + +## Contributing + +You want to contribute to this project? Wow, thanks! So please just fork it and +send me a pull request. diff --git a/app/Main.hs b/app/Main.hs index afbce53..a476237 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,8 +10,9 @@ import Data.List ( intercalate ) import Environment ( Environment(Environment), commit, commitEnvVars - , fillEnvironment, pullRequest, pullRequestEnvVars, repoSlug - , repoSlugEnvVars, tokenEnvVars ) + , fillEnvironment, owner, ownerEnvVars, pullRequest + , pullRequestEnvVars, repository, repositoryEnvVars + , tokenEnvVars ) import Log as L ( info ) import Log ( initLogger, notice, warn ) @@ -72,9 +73,12 @@ environment = Environment <$> strOption (long "commit" <> short 'c' <*> strOption (long "pull-request" <> short 'p' <> envHelp "Pull request number" pullRequestEnvVars <> metavar "PULL_REQUEST" <> value "") - <*> strOption (long "repo-slug" <> short 'r' - <> envHelp "GitHub repository slug (owner/repo)" - repoSlugEnvVars <> metavar "REPOSLUG" <> value "") + <*> strOption (long "repository" <> short 'r' + <> envHelp "GitHub repository" repositoryEnvVars + <> metavar "REPOSITORY" <> value "") + <*> strOption (long "owner" <> short 'o' + <> envHelp "GitHub owner" ownerEnvVars <> metavar "OWNER" + <> value "") <*> strOption (long "token" <> short 't' <> envHelp "Token" tokenEnvVars <> metavar "TOKEN" <> value "") <**> helper where @@ -114,7 +118,8 @@ run (Args e v d) = do env <- fillEnvironment e d L.info . printf "Using commit: %s" $ env ^. commit L.info . printf "Using pull request: %s" $ env ^. pullRequest - L.info . printf "Using repository slug: %s" $ env ^. repoSlug + L.info . printf "Using repository: %s" $ env ^. repository + L.info . printf "Using owner: %s" $ env ^. owner -- Parse loop notice "Processing input from stdin..." diff --git a/nix/default.nix b/nix/default.nix index c922da3..9f0f6fd 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -1,7 +1,7 @@ -{ mkDerivation, aeson, ansi-terminal, base, hpack, hslogger, lens -, megaparsec, optparse-applicative, persistent, persistent-sqlite -, persistent-template, regex-compat, split, stdenv, tasty -, tasty-hspec, tasty-quickcheck, text, time +{ mkDerivation, ansi-terminal, base, bytestring, github, hpack +, hslogger, lens, megaparsec, optparse-applicative, persistent +, persistent-sqlite, persistent-template, regex-compat, stdenv +, tasty, tasty-hspec, tasty-quickcheck, text, time, vector }: mkDerivation { pname = "performabot"; @@ -10,15 +10,16 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson ansi-terminal base hslogger lens megaparsec persistent - persistent-sqlite persistent-template regex-compat split text time + ansi-terminal base bytestring github hslogger lens megaparsec + persistent persistent-sqlite persistent-template regex-compat text + time vector ]; libraryToolDepends = [ hpack ]; executableHaskellDepends = [ base hslogger lens optparse-applicative ]; testHaskellDepends = [ - aeson base lens megaparsec tasty tasty-hspec tasty-quickcheck + base lens megaparsec tasty tasty-hspec tasty-quickcheck ]; prePatch = "hpack"; homepage = "https://github.com/saschagrunert/performabot#readme"; diff --git a/nix/nixpkgs.json b/nix/nixpkgs.json index 7972549..d949429 100644 --- a/nix/nixpkgs.json +++ b/nix/nixpkgs.json @@ -1,7 +1,7 @@ { "url": "https://github.com/nixos/nixpkgs", - "rev": "80172aa0a6fad62d1371dee8318725573e7ac808", - "date": "2019-06-23T14:58:17+01:00", - "sha256": "0gsjad0mlg32mhr7cb5sgpilafmm7fjbch2nvvhc3y8f52r20nrw", + "rev": "2072043efbd74b40ef107e235287ba91e489695b", + "date": "2019-06-27T14:15:37+02:00", + "sha256": "1f8jdb4w6sg6h66gn4n1gaq6bivjmlagxzwni9n7nqz3h39ivpwx", "fetchSubmodules": false } diff --git a/nix/overlay.nix b/nix/overlay.nix new file mode 100644 index 0000000..7f32aa3 --- /dev/null +++ b/nix/overlay.nix @@ -0,0 +1,28 @@ +_: pkgs: { + haskellPackages = pkgs.haskellPackages.override (old: { + overrides = pkgs.lib.composeExtensions (old.overrides or (_: _: {})) (self: super: { + binary-instances = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.overrideCabal super.binary-instances (old: { + libraryHaskellDepends = old.libraryHaskellDepends ++ [ + self.binary-orphans_1_0_1 + ]; + broken = false; + })); + binary-orphans_1_0_1 = pkgs.haskell.lib.dontCheck super.binary-orphans_1_0_1; + github = pkgs.haskell.lib.overrideCabal super.github (old: { + broken = false; + version = "0.22"; + sha256 = "15py79qcpj0k331i42njgwkirwyiacbc5razmxnm4672dvvip2qk"; + libraryHaskellDepends = old.libraryHaskellDepends ++ [ + self.binary-instances self.exceptions self.transformers-compat + ]; + }); + time-compat = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.overrideCabal super.time-compat (old: { + version = "1.9.2.2"; + sha256 = "05va0rqs759vbridbcl6hksp967j9anjvys8vx72fnfkhlrn2s52"; + libraryHaskellDepends = old.libraryHaskellDepends ++ [ + self.base-orphans + ]; + })); + }); + }); +} diff --git a/nix/release-static.nix b/nix/release-static.nix index 702fae5..7588ae4 100644 --- a/nix/release-static.nix +++ b/nix/release-static.nix @@ -1,5 +1,7 @@ let - pkgs = (import ./nixpkgs.nix { }).pkgsMusl; + pkgs = (import ./nixpkgs.nix { + overlays = [(import ./overlay.nix)]; + }).pkgsMusl; in (pkgs.haskellPackages.callPackage ./default.nix { }).overrideAttrs(old: { doCheck = false; diff --git a/nix/release.nix b/nix/release.nix index b86682e..d6b6f1c 100644 --- a/nix/release.nix +++ b/nix/release.nix @@ -1,4 +1,4 @@ let - pkgs = import ./nixpkgs.nix { }; + pkgs = import ./nixpkgs.nix { overlays = [(import ./overlay.nix)]; }; in pkgs.haskellPackages.callPackage ./default.nix { } diff --git a/package.yaml b/package.yaml index 530a871..1fcfbf6 100644 --- a/package.yaml +++ b/package.yaml @@ -55,8 +55,9 @@ executables: library: source-dirs: src dependencies: - - aeson - ansi-terminal + - bytestring + - github - hslogger - lens - megaparsec @@ -64,9 +65,9 @@ library: - persistent-sqlite - persistent-template - regex-compat - - split - text - time + - vector when: - condition: flag(static) cc-options: -static -fPIC @@ -81,7 +82,6 @@ tests: - -threaded - -with-rtsopts=-N dependencies: - - aeson - lens - megaparsec - performabot diff --git a/performabot.cabal b/performabot.cabal index 2cc31b7..104a4fe 100644 --- a/performabot.cabal +++ b/performabot.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 7b4271c5f25eb1fc060842b0673460b631c6ed5e1ea28a244b5546a597ae7d70 +-- hash: 0c627d55fff6db0f3745e774010e624c0adbc7fa265e79a60506b182fbc4f8c9 name: performabot version: 0.1.0 @@ -31,10 +31,12 @@ flag static library exposed-modules: Environment + Github Log Model Parser ParserGo + Pretty Result other-modules: Paths_performabot @@ -43,9 +45,10 @@ library default-extensions: GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes TemplateHaskell TypeFamilies ghc-options: -Werror -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missed-specialisations -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-unsafe build-depends: - aeson - , ansi-terminal + ansi-terminal , base + , bytestring + , github , hslogger , lens , megaparsec @@ -53,9 +56,9 @@ library , persistent-sqlite , persistent-template , regex-compat - , split , text , time + , vector if flag(static) cc-options: -static -fPIC ld-options: -static -fPIC @@ -90,8 +93,7 @@ test-suite performabot-test default-extensions: GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes TemplateHaskell TypeFamilies ghc-options: -Werror -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missed-specialisations -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-unsafe -rtsopts -threaded -with-rtsopts=-N build-depends: - aeson - , base + base , lens , megaparsec , performabot diff --git a/src/Environment.hs b/src/Environment.hs index 5c50073..2187aef 100644 --- a/src/Environment.hs +++ b/src/Environment.hs @@ -6,20 +6,20 @@ module Environment , commit , commitEnvVars , fillEnvironment + , owner + , ownerEnvVars , pullRequest , pullRequestEnvVars - , repoSlug - , repoSlugEnvVars + , repository + , repositoryEnvVars + , token , tokenEnvVars ) where import Control.Lens ( (.~), (^.), makeLenses ) import Control.Monad ( mapM, msum ) -import Data.Aeson.TH - ( defaultOptions, deriveJSON, fieldLabelModifier ) import Data.List ( intercalate ) -import Data.List.Split ( splitOn ) import Log ( err ) @@ -30,62 +30,57 @@ import Text.Printf ( printf ) data Environment = Environment { _commit :: String , _pullRequest :: String - , _repoSlug :: String + , _repository :: String + , _owner :: String , _token :: String } deriving Show $(makeLenses ''Environment) -deriveJSON defaultOptions { fieldLabelModifier = drop 1 } ''Environment - +-- | Try to fill the environment from local variables fillEnvironment :: Environment -> Bool -> IO Environment fillEnvironment e d = do c <- getEnv (e ^. commit) "commit" commitEnvVars p <- getEnv (e ^. pullRequest) "pull request" pullRequestEnvVars - r <- getEnv (e ^. repoSlug) "repo slug" repoSlugEnvVars + r <- getEnv (e ^. repository) "repository" repositoryEnvVars + o <- getEnv (e ^. owner) "owner" ownerEnvVars t <- getEnv (e ^. token) "token" tokenEnvVars -- Validate the other environment variables if not d && any null [ c, p, r, t ] then exitFailure - else return $ token .~ t $ pullRequest .~ p $ commit .~ c $ - repoSlug .~ r $ e + else return $ token .~ t $ pullRequest .~ p $ commit .~ c $ owner .~ o $ + repository .~ r $ e -- | The prefix for local env vars prefix :: String -> String prefix = (++) "PB_" --- | The split chars for defining multiple env vars in one single value -envVarSplit :: String -envVarSplit = "/$" - -- | Possible token environment variables sorted by priority tokenEnvVars :: [String] tokenEnvVars = [ prefix "TOKEN" ] --- | Possible repository slug (`username/project`) environment variables sorted --- by priority -repoSlugEnvVars :: [String] -repoSlugEnvVars = - [ prefix "REPOSLUG" - , "CIRCLE_PROJECT_USERNAME" ++ envVarSplit ++ "CIRCLE_PROJECT_REPONAME" - , "TRAVIS_REPO_SLUG" - ] +-- | Possible repository environment variables sorted by priority +repositoryEnvVars :: [String] +repositoryEnvVars = [ prefix "REPOSITORY", "CIRCLE_PROJECT_REPONAME" ] + +-- | Possible repository environment variables sorted by priority +ownerEnvVars :: [String] +ownerEnvVars = [ prefix "OWNER", "CIRCLE_PROJECT_USERNAME" ] -- | Possible commit environment variables sorted by priority commitEnvVars :: [String] -commitEnvVars = [ prefix "COMMIT", "CIRCLE_SHA1", "TRAVIS_COMMIT" ] +commitEnvVars = [ prefix "COMMIT", "CIRCLE_SHA1" ] -- | Possible pull request environment variables sorted by priority pullRequestEnvVars :: [String] -pullRequestEnvVars = - [ prefix "PULL_REQUEST", "CIRCLE_PR_NUMBER", "TRAVIS_PULL_REQUEST" ] +pullRequestEnvVars = [ prefix "PULL_REQUEST", "CIRCLE_PR_NUMBER" ] -- | Generic environment variable retrieval getEnv :: String -> String -> [String] -> IO String getEnv "" t v = do - e <- mapM lookupSplitEnv v + e <- mapM lookupEnv v case msum e of Just b -> return b _ -> do @@ -97,9 +92,3 @@ getEnv "" t v = do return "" getEnv x _ _ = return x - --- | Lookup env vars but split them by `envVarSplit` before -lookupSplitEnv :: String -> IO (Maybe String) -lookupSplitEnv i = do - e <- mapM lookupEnv $ splitOn envVarSplit i - return $ intercalate "/" <$> sequence e diff --git a/src/Github.hs b/src/Github.hs new file mode 100644 index 0000000..1b917f9 --- /dev/null +++ b/src/Github.hs @@ -0,0 +1,116 @@ +-- | Github related actions +-- +-- @since 0.1.0 +module Github ( baseCommit, comment ) where + +import Control.Lens ( (^.) ) + +import Data.ByteString.Char8 as C ( pack ) +import Data.List ( find ) +import Data.Text as T ( Text, isInfixOf, pack ) +import Data.Vector ( Vector, toList ) + +import Environment + ( Environment, owner, pullRequest, repository, token ) + +import GitHub ( Auth(OAuth) ) +import GitHub.Data.Comments ( Comment, commentUrl ) +import GitHub.Data.Definitions + ( Error, IssueNumber(IssueNumber), Owner ) +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.URL ( getUrl ) +import GitHub.Endpoints.Issues.Comments + ( comments, createComment, editComment ) +import GitHub.Endpoints.PullRequests ( pullRequest' ) + +import Log ( debug, err, notice ) + +import Pretty ( header ) + +import System.Exit ( exitFailure ) + +import Text.Printf ( printf ) + +-- | Authenticate from string token +getAuth :: Environment -> Auth +getAuth e = OAuth . C.pack $ e ^. token + +-- | Comment the provided string +comment :: Environment -> String -> IO () +comment e x = do + p <- maybeInt $ e ^. pullRequest + let a = getAuth e + o = N . T.pack $ e ^. owner + r = N . T.pack $ e ^. repository + i = IssueNumber p + l = T.pack x + + cs <- getComments o r i + case isFromPerformabot $ toList cs of + Just s -> do + debug . printf "Found issue to edit: %s" $ show s + cc <- editComment a o r (Id $ issueCommentId s) l + handleCommentErr cc "edit" + Nothing -> do + debug "No issue found, creating new" + cc <- createComment a o r i l + handleCommentErr cc "create" + +-- | Retrieve all comments +getComments + :: Name Owner -> Name Repo -> IssueNumber -> IO (Vector IssueComment) +getComments o r i = do + mcs <- comments o r i + case mcs of + Left f -> do + err $ printf "Unable to retrieve comments" + debug $ show f + exitFailure + Right cs -> return cs + +-- | General comment error handling +handleCommentErr :: Either Error Comment -> String -> IO () +handleCommentErr x t = case x of + Left f -> do + err $ printf "Unable to %s comment" t + debug $ show f + exitFailure + Right c -> notice $ + printf "Comment %s successful: %s" t (getUrl $ commentUrl c) + +-- | Finds comments from performabot +isFromPerformabot :: [IssueComment] -> Maybe IssueComment +isFromPerformabot = find $ T.isInfixOf (T.pack header) . issueCommentBody + +-- | Retrieve the corresponding base commit for the pull request +baseCommit :: Environment -> IO T.Text +baseCommit e = do + p <- maybeInt $ e ^. pullRequest + i <- pullRequest' (Just $ getAuth e) + (N . T.pack $ e ^. owner) + (N . T.pack $ e ^. repository) + (IssueNumber p) + case i of + Left f -> do + err . printf "Unable to retrieve pull request #%s" $ + e ^. pullRequest + debug $ show f + exitFailure + Right pr -> do + let c = pullRequestCommitSha $ pullRequestBase pr + debug $ printf "Found PR base commit: %s" c + return c + +-- | Try to read the integer from the string and fail early if not possible +maybeInt :: String -> IO Int +maybeInt s = case reads s of + [ (x, "") ] -> return x + _ -> do + err "Unable to parse pull request number" + exitFailure diff --git a/src/Model.hs b/src/Model.hs index dabe26d..ecaeb95 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -1,28 +1,10 @@ +{-# OPTIONS_GHC -Wno-missing-export-lists #-} + -- | Database models -- -- @since 0.1.0 -module Model - ( Benchmark(Benchmark) - , Benchmarks - , BenchmarkId - , Test(Test) - , TestId - , benchmarkAverage - , benchmarkDerivation - , benchmarkName - , benchmarkSamples - , benchmarkUnit - , emptyBenchmark - , migrateAll - , testBenchmarks - , testCommit - , testPullRequest - , testRepoSlug - , testTime - ) where +module Model where -import Data.Aeson.TH - ( defaultOptions, deriveJSON, fieldLabelModifier ) import Data.Text ( Text ) import Data.Time ( UTCTime ) @@ -39,12 +21,6 @@ share [ mkPersist sqlSettings { mpsGenerateLenses = True } -- | Multiple Benchmarks type Benchmarks = [Benchmark] --- | Drop the "_benchmark" from the Benchmark -deriveJSON defaultOptions { fieldLabelModifier = drop 10 } ''Benchmark - --- | Drop the "_result" from the Result -deriveJSON defaultOptions { fieldLabelModifier = drop 5 } ''Test - -- | Get a new empty Benchmark instance emptyBenchmark :: Benchmark emptyBenchmark = Benchmark 0 0 "" 0 "" diff --git a/src/Pretty.hs b/src/Pretty.hs new file mode 100644 index 0000000..c8536dc --- /dev/null +++ b/src/Pretty.hs @@ -0,0 +1,92 @@ +-- | The result pretty printer +-- +-- @since 0.1.0 +module Pretty ( header, prettyPrint ) where + +import Control.Lens ( (^.) ) + +import Data.List ( find ) +import Data.Text as T + ( Text, append, length, replicate, take, unpack ) + +import Model ( Benchmark, Benchmarks, Test, benchmarkAverage + , benchmarkDerivation, benchmarkName + , benchmarkSamples, benchmarkUnit, testCommit ) + +import Text.Printf ( printf ) + +-- | Pretty print the Benchmarks +prettyPrint :: Benchmarks -> Maybe (Test, Benchmarks) -> String +prettyPrint x Nothing = header ++ "Nothing to compare against." ++ nl ++ nl + ++ tableHeader ++ nl ++ sep ++ unwords (lineR <$> x) ++ nl ++ tableFooter +prettyPrint x (Just (t, b)) = header + ++ printf "Comparing to commit %s" (T.take 7 $ t ^. testCommit) ++ nl ++ nl + ++ tableHeader ++ unwords (lineDiff b <$> x) ++ nl ++ tableFooter + +-- | Print a line diff between two benchmarks +lineDiff :: Benchmarks -> Benchmark -> String +lineDiff c b = case findName (b ^. benchmarkName) c of + Nothing -> nl ++ sep ++ lineR b + Just x -> nl ++ sep ++ line "-" x ++ line "+" b ++ dline x b + +-- | Find a matching benchmark by name +findName :: T.Text -> Benchmarks -> Maybe Benchmark +findName n = find (\x -> n == x ^. benchmarkName) + +-- | A line for a benchmark without any comparison value +lineR :: Benchmark -> String +lineR = line " " + +-- | Create a single result line +line :: String -> Benchmark -> String +line x b = nl ++ printf "%s %s% .3f%s % .3f%s %*d" + x + (T.unpack . fillOrTrim $ b ^. benchmarkName) + (b ^. benchmarkAverage) + (b ^. benchmarkUnit) + (b ^. benchmarkDerivation) + (b ^. benchmarkUnit) + (3 :: Int) + (b ^. benchmarkSamples) + +-- | Print a diff line +dline :: Benchmark -> Benchmark -> String +dline a b = nl ++ printf "= %s% .3f%s % .3f%s %*d" + (T.unpack $ fillOrTrim "") + (b ^. benchmarkAverage - a ^. benchmarkAverage) + (b ^. benchmarkUnit) + (b ^. benchmarkDerivation - a ^. benchmarkDerivation) + (b ^. benchmarkUnit) + (3 :: Int) + (b ^. benchmarkSamples - a ^. benchmarkSamples) + +-- | Fillup with space or trim string +fillOrTrim :: T.Text -> T.Text +fillOrTrim x + | T.length x <= maxLength = T.append x $ + T.replicate (maxLength - T.length x) " " + | otherwise = fillOrTrim $ T.append (T.take (maxLength - 3) x) "…" + where + maxLength = 34 + +-- | The comment header +header :: String +header = "### Performabot Result \129302" ++ nl ++ nl + +-- | The table header +tableHeader :: String +tableHeader = "```diff" ++ nl + ++ "@@ Performance Diff @@" ++ nl + ++ "## Ø ± × ##" + +-- | The table footer +tableFooter :: String +tableFooter = sep ++ nl ++ "```" + +-- | The separator +sep :: String +sep = "==========================================================" + +-- | A newline +nl :: String +nl = "\n" diff --git a/src/Result.hs b/src/Result.hs index 688d1cd..02d3d36 100644 --- a/src/Result.hs +++ b/src/Result.hs @@ -4,24 +4,32 @@ module Result ( amount, initParserStep, parseStepIO, save ) where import Control.Lens ( (^.) ) +import Control.Monad.IO.Class ( liftIO ) import Data.Text ( Text, pack ) import Data.Time.Clock ( getCurrentTime ) -import Database.Persist ( insert ) +import Database.Persist ( (<-.), (==.), SelectOpt(Asc, LimitTo) + , entityVal, insert, selectList ) import Database.Persist.Sqlite ( runMigration, runSqlite ) import Environment - ( Environment, commit, pullRequest, repoSlug ) + ( Environment, commit, owner, pullRequest, repository ) -import Log ( debug, noticeR ) +import Github ( baseCommit, comment ) -import Model ( Benchmarks, Test(Test), migrateAll ) +import Log ( debug, info, notice, noticeR ) + +import Model + ( Benchmarks, EntityField(TestCommit, BenchmarkId, TestTime) + , Test(Test), migrateAll, testBenchmarks ) import Parser ( State(Failure, Init, Ok) ) import qualified ParserGo as Go ( parse ) +import Pretty ( prettyPrint ) + import Text.Printf ( printf ) -- | A single parser step consists of an intermediate state and result @@ -55,7 +63,7 @@ amount (_, r) = length r -- | Print a debug message for the current step debugStep :: Step -> IO () debugStep (Failure f, r) = do - debug $ printf "Parse error: %s" f + debug $ printf "Parse error:\n%s" f debugResult r debugStep (_, r) = debugResult r @@ -66,17 +74,46 @@ debugResult r = debug . printf "Current result: %s" $ show r -- | Sen the provided data to the given url including the environment save :: Step -> Environment -> IO () save (_, b) e = do - t <- getCurrentTime - _ <- runSqlite db $ do - runMigration migrateAll - bids <- mapM insert b - insert $ Test t - (pack $ e ^. commit) - (pack $ e ^. repoSlug) - (pack $ e ^. pullRequest) - bids - return () + c <- baseCommit e + info "Base commit retrieval successful" + insertInDB e b + info "Database insertion successful" + pb <- entryForCommit c + let r = prettyPrint b pb + notice $ printf "The report: %s" r + comment e 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 + runMigration migrateAll + t <- liftIO getCurrentTime + bids <- mapM insert b + _ <- insert $ Test t + (pack $ e ^. commit) + (pack $ e ^. repository) + (pack $ e ^. owner) + (pack $ e ^. pullRequest) + bids + return () + +-- | Try to retrieve a test for a given commit +entryForCommit :: Text -> IO (Maybe (Test, Benchmarks)) +entryForCommit c = runSqlite db $ do + runMigration migrateAll + t <- selectList [ TestCommit ==. c ] [ LimitTo 1, Asc TestTime ] + case t of + [ i ] -> do + liftIO . debug . printf "Base test entry: %s" $ show i + let v = entityVal i + bs <- selectList [ BenchmarkId <-. v ^. testBenchmarks ] [] + let b = entityVal <$> bs + liftIO . debug . printf "Base test benchmarks: %s" $ show b + return $ Just (v, b) + _ -> do + liftIO $ debug "No last test entry found" + return Nothing diff --git a/src/model b/src/model index 588208d..9caebf7 100644 --- a/src/model +++ b/src/model @@ -1,10 +1,11 @@ Test time UTCTime commit Text - repoSlug Text + repository Text + owner Text pullRequest Text benchmarks [BenchmarkId] - deriving Show + deriving Show Benchmark average Double @@ -12,4 +13,4 @@ Benchmark name Text samples Int unit Text - deriving Show + deriving Show diff --git a/stack.yaml b/stack.yaml index 8496551..b3c265d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,3 +6,8 @@ nix: resolver: lts-13.26 packages: - . +extra-deps: + - github-0.22@sha256:13f09e904248a40dd173c08f2859d0dfda178a7c27f88df20b70a0d5a7614757,6909 + - binary-instances-1@sha256:e7768b92f34bc40cc5cabecc5c143dee6ab4bcb5eb441d58e15a0b000d64940b,2591 + - binary-orphans-1.0.1@sha256:76c4afdcd2187af0f65dd647779f1b126c505ea0882992e4ee7ad847400a9c6b,2004 + - time-compat-1.9.2.2@sha256:9998dc1b77b5067572ab708e94750f1061152f342e92ad1aba38aae63581174d,4209