From b7a3f9ab91f316613645da7fc2944df59900d916 Mon Sep 17 00:00:00 2001 From: Sascha Grunert Date: Mon, 24 Jun 2019 17:25:31 +0200 Subject: [PATCH] Separate environment (#26) --- app/Main.hs | 17 ++--- nix/default.nix | 10 ++- package.yaml | 5 +- performabot.cabal | 15 ++-- src/{Env.hs => Environment.hs} | 47 ++++++++----- src/Model.hs | 48 +++---------- src/ParserResult.hs | 124 --------------------------------- src/Result.hs | 93 +++++++++++++++++++++++++ src/model | 15 ++++ test/ResultSpec.hs | 2 +- 10 files changed, 167 insertions(+), 209 deletions(-) rename src/{Env.hs => Environment.hs} (67%) delete mode 100644 src/ParserResult.hs create mode 100644 src/Result.hs create mode 100644 src/model diff --git a/app/Main.hs b/app/Main.hs index 57c6cf8..3b02d50 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -8,17 +8,14 @@ import Control.Monad ( foldM ) import Data.List ( intercalate ) -import Env - ( commitEnvVars, fillEnvironment, pullRequestEnvVars +import Environment + ( Environment(Environment), commit, commitEnvVars + , fillEnvironment, pullRequest, pullRequestEnvVars, repoSlug , repoSlugEnvVars, tokenEnvVars ) import Log as L ( info ) import Log ( initLogger, notice, warn ) -import Model - ( Environment(Environment), environmentCommit - , environmentPullRequest, environmentRepoSlug ) - import Options.Applicative as O ( info ) import Options.Applicative ( (<**>), Parser, ParserInfo @@ -29,7 +26,7 @@ import Options.Applicative , helper, infoOption, internal, long, many, metavar, short , short, strOption, switch, value ) -import ParserResult +import Result ( amount, initParserStep, parseStepIO, save ) import System.Exit ( exitFailure ) @@ -116,9 +113,9 @@ run (Args e v d) = do -- Prepare environment env <- fillEnvironment e d - L.info . printf "Using commit: %s" $ env ^. environmentCommit - L.info . printf "Using pull request: %s" $ env ^. environmentPullRequest - L.info . printf "Using repository slug: %s" $ env ^. environmentRepoSlug + 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 -- Parse loop notice "Processing input from stdin..." diff --git a/nix/default.nix b/nix/default.nix index d9e14ed..2a615db 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -1,6 +1,5 @@ -{ mkDerivation, aeson, ansi-terminal, base, bytestring, directory -, hpack, hslogger, http-conduit, lens, megaparsec -, optparse-applicative, persistent, persistent-sqlite +{ mkDerivation, aeson, ansi-terminal, base, hpack, hslogger, lens +, megaparsec, optparse-applicative, persistent, persistent-sqlite , persistent-template, split, stdenv, tasty, tasty-hspec , tasty-quickcheck, temporary, text, time }: @@ -11,9 +10,8 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson ansi-terminal base bytestring directory hslogger http-conduit - lens megaparsec persistent persistent-sqlite persistent-template - split temporary text time + aeson ansi-terminal base hslogger lens megaparsec persistent + persistent-sqlite persistent-template split temporary text time ]; libraryToolDepends = [ hpack ]; executableHaskellDepends = [ diff --git a/package.yaml b/package.yaml index 9b6d252..5415ba1 100644 --- a/package.yaml +++ b/package.yaml @@ -20,7 +20,7 @@ flags: manual: false ghc-options: - # - -Werror + - -Werror - -Weverything - -Wno-all-missed-specialisations - -Wno-implicit-prelude @@ -57,10 +57,7 @@ library: dependencies: - aeson - ansi-terminal - - bytestring - - directory - hslogger - - http-conduit - lens - megaparsec - persistent diff --git a/performabot.cabal b/performabot.cabal index 37cbbda..1b57288 100644 --- a/performabot.cabal +++ b/performabot.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 6dd0c8bb11e5e152228978bd9c385e7a0c7d3f0c96a4d034f60166c3e020325a +-- hash: 78812b67fb634b70ac93b92d47f01a0f4fbabb2234f2c82f01904e75ad697fe1 name: performabot version: 0.1.0 @@ -30,26 +30,23 @@ flag static library exposed-modules: - Env + Environment Log Model Parser ParserGo - ParserResult + Result other-modules: Paths_performabot hs-source-dirs: src default-extensions: GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes TemplateHaskell TypeFamilies - ghc-options: -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missed-specialisations -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-unsafe + 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 , base - , bytestring - , directory , hslogger - , http-conduit , lens , megaparsec , persistent @@ -71,7 +68,7 @@ executable performabot hs-source-dirs: app default-extensions: GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes TemplateHaskell TypeFamilies - ghc-options: -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 + 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: base , hslogger @@ -91,7 +88,7 @@ test-suite performabot-test hs-source-dirs: test default-extensions: GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes TemplateHaskell TypeFamilies - ghc-options: -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 + 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 diff --git a/src/Env.hs b/src/Environment.hs similarity index 67% rename from src/Env.hs rename to src/Environment.hs index b926c7b..5c50073 100644 --- a/src/Env.hs +++ b/src/Environment.hs @@ -1,45 +1,56 @@ -- | System environment handling -- -- @since 0.1.0 -module Env - ( commitEnvVars +module Environment + ( Environment(Environment) + , commit + , commitEnvVars , fillEnvironment + , pullRequest , pullRequestEnvVars + , repoSlug , repoSlugEnvVars , tokenEnvVars ) where -import Control.Lens ( (.~), (^.) ) +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 Data.Text ( Text, pack ) -import qualified Data.Text as T ( null ) import Log ( err ) -import Model - ( Environment, environmentCommit, environmentPullRequest - , environmentRepoSlug, environmentToken ) - import System.Environment ( lookupEnv ) import System.Exit ( exitFailure ) import Text.Printf ( printf ) +data Environment = Environment { _commit :: String + , _pullRequest :: String + , _repoSlug :: String + , _token :: String + } + deriving Show + +$(makeLenses ''Environment) + +deriveJSON defaultOptions { fieldLabelModifier = drop 1 } ''Environment + fillEnvironment :: Environment -> Bool -> IO Environment fillEnvironment e d = do - c <- getEnv (e ^. environmentCommit) "commit" commitEnvVars - p <- getEnv (e ^. environmentPullRequest) "pull request" pullRequestEnvVars - r <- getEnv (e ^. environmentRepoSlug) "repo slug" repoSlugEnvVars - t <- getEnv (e ^. environmentToken) "token" tokenEnvVars + c <- getEnv (e ^. commit) "commit" commitEnvVars + p <- getEnv (e ^. pullRequest) "pull request" pullRequestEnvVars + r <- getEnv (e ^. repoSlug) "repo slug" repoSlugEnvVars + t <- getEnv (e ^. token) "token" tokenEnvVars -- Validate the other environment variables - if not d && any T.null [ r, c, p, t ] + if not d && any null [ c, p, r, t ] then exitFailure - else return $ environmentToken .~ t $ environmentPullRequest .~ p $ - environmentCommit .~ c $ environmentRepoSlug .~ r $ e + else return $ token .~ t $ pullRequest .~ p $ commit .~ c $ + repoSlug .~ r $ e -- | The prefix for local env vars prefix :: String -> String @@ -72,11 +83,11 @@ pullRequestEnvVars = [ prefix "PULL_REQUEST", "CIRCLE_PR_NUMBER", "TRAVIS_PULL_REQUEST" ] -- | Generic environment variable retrieval -getEnv :: Text -> String -> [String] -> IO Text +getEnv :: String -> String -> [String] -> IO String getEnv "" t v = do e <- mapM lookupSplitEnv v case msum e of - Just b -> return $ pack b + Just b -> return b _ -> do err $ printf ("No %s found via the $%s environment " ++ "variable%s or the command line") diff --git a/src/Model.hs b/src/Model.hs index 1475f74..306cd76 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -5,8 +5,6 @@ module Model ( Benchmark(Benchmark) , BenchmarkId , Entry - , Environment(Environment) - , EnvironmentId , Test(Test) , TestId , benchmarkAverage @@ -15,51 +13,30 @@ module Model , benchmarkSamples , benchmarkUnit , emptyBenchmark - , environmentCommit - , environmentPullRequest - , environmentRepoSlug - , environmentToken , migrateAll , testBenchmarks - , testEnvironment + , testCommit + , testPullRequest + , testRepoSlug , testTime ) where import Data.Aeson.TH ( defaultOptions, deriveJSON, fieldLabelModifier ) -import Data.Text ( Text ) -import Data.Time ( UTCTime ) +import Data.Text ( Text ) +import Data.Time ( UTCTime ) -import Database.Persist.TH ( mkMigrate, mkPersist, mpsGenerateLenses - , persistLowerCase, share, sqlSettings ) +import Database.Persist.Quasi ( lowerCaseSettings ) +import Database.Persist.TH + ( mkMigrate, mkPersist, mpsGenerateLenses, persistFileWith + , share, sqlSettings ) share [ mkPersist sqlSettings { mpsGenerateLenses = True } , mkMigrate "migrateAll" ] - [persistLowerCase| -Test - benchmarks [BenchmarkId] - environment EnvironmentId - time UTCTime - deriving Show + $(persistFileWith lowerCaseSettings "src/model") -Environment - commit Text - pullRequest Text - repoSlug Text - token Text - deriving Show - -Benchmark - average Double - derivation Double - name Text - samples Int - unit Text - deriving Show -|] - -type Entry = (Environment, [Benchmark]) +type Entry = (Test, [Benchmark]) -- | Drop the "_benchmark" from the Benchmark deriveJSON defaultOptions { fieldLabelModifier = drop 10 } ''Benchmark @@ -67,9 +44,6 @@ deriveJSON defaultOptions { fieldLabelModifier = drop 10 } ''Benchmark -- | Drop the "_result" from the Result deriveJSON defaultOptions { fieldLabelModifier = drop 5 } ''Test --- | Drop the "_environment" from the Environment -deriveJSON defaultOptions { fieldLabelModifier = drop 12 } ''Environment - -- | Get a new empty Benchmark instance emptyBenchmark :: Benchmark emptyBenchmark = Benchmark 0 0 "" 0 "" diff --git a/src/ParserResult.hs b/src/ParserResult.hs deleted file mode 100644 index 145a16d..0000000 --- a/src/ParserResult.hs +++ /dev/null @@ -1,124 +0,0 @@ --- | Result and state handling --- --- @since 0.1.0 -module ParserResult ( ParserResult, amount, initParserStep, parseStepIO, save ) where - -import Control.Exception ( displayException, try ) - -import Data.Aeson ( encodeFile ) -import Data.ByteString.Lazy.Char8 as C ( unpack ) - -import Log ( debug, err, notice, noticeR ) - -import Model ( Benchmark, Entry, Environment ) - -import Network.HTTP.Simple - ( HttpException, Request, getResponseBody - , getResponseStatusCode, httpLBS, parseRequest - , setRequestBodyJSON ) - -import Parser ( State(Failure, Init, Ok) ) - -import qualified ParserGo as Go ( parse ) - -import System.Directory ( removePathForcibly ) -import System.Exit ( exitFailure ) -import System.IO.Temp ( emptySystemTempFile ) - -import Text.Printf ( printf ) - --- | The result of the complete run -type ParserResult = [Benchmark] - --- | A single parser step consists of an intermediate state and result -type ParserStep = (State, ParserResult) - --- | Initial parser step for convenience -initParserStep :: ParserStep -initParserStep = (Init, []) - --- | Go one step forward and log output -parseStepIO :: ParserStep -> String -> IO ParserStep -parseStepIO s line = do - noticeR line - let r = parseStep s line - debugStep r - return r - --- | Go one step forward by parsing the input String -parseStep :: ParserStep -> String -> ParserStep -parseStep (s, r) i = let ns = Go.parse s i in (ns, appendBenchmark ns r) - --- | Append the succeeding result if possible -appendBenchmark :: State -> ParserResult -> ParserResult -appendBenchmark (Ok b) r = r ++ pure b -appendBenchmark _ r = r - --- | Retrieve the amount of benchmark results for the provided ParserStep -amount :: ParserStep -> Int -amount (_, r) = length r - --- | Print a debug message for the current step -debugStep :: ParserStep -> IO () -debugStep (Failure f, r) = do - debug $ printf "Parse error: %s" f - debugResult r -debugStep (_, r) = debugResult r - --- | Print a debug message for the current result -debugResult :: ParserResult -> IO () -debugResult r = debug . printf "Current result: %s" $ show r - --- | Store the current result on disk -toDisk :: Entry -> IO FilePath -toDisk b = do - f <- emptySystemTempFile "result-.json" - debug $ printf "Writing to temp file: %s" f - encodeFile f b - return f - --- | Sen the provided data to the given url including the environment -save :: ParserStep -> Environment -> IO () -save (_, r) e = do - let body = (e, r) - p <- toDisk body - request <- buildRequest "" p - debug . printf "Doing HTTP request:\n%s" $ show request - doRequest request body p - --- | Do the provided request -doRequest :: Request -> Entry -> FilePath -> IO () -doRequest r b p = do - response <- try . httpLBS $ setRequestBodyJSON b r - case response of - Right res -> case getResponseStatusCode res of - 200 -> do - notice "Successfully sent" - removePathForcibly p - debug "Removed temp file" - code -> do - err $ printf "Got wrong HTTP status code: %d" code - debug . printf "Got sesponse:\n%s" . C.unpack $ - getResponseBody res - logFilePath p - Left exception -> do - err "Unable to do HTTP request" - debug . printf "Exception details:\n%s" $ - displayException (exception :: HttpException) - logFilePath p - --- | Build the HTTP post request from the given URL and path. The function does --- earily exit on failure. -buildRequest :: String -> FilePath -> IO Request -buildRequest u p = do - r <- try . parseRequest $ printf "POST %s" u - case r :: Either HttpException Request of - Right req -> return req - Left _ -> do - err $ printf "Invalid URL provided: %s" u - logFilePath p - exitFailure - --- | Log the file path convenience function -logFilePath :: FilePath -> IO () -logFilePath p = notice $ printf "You can retry by using the file %s" p diff --git a/src/Result.hs b/src/Result.hs new file mode 100644 index 0000000..14d079e --- /dev/null +++ b/src/Result.hs @@ -0,0 +1,93 @@ +-- | Result and state handling +-- +-- @since 0.1.0 +module Result ( Result, amount, initParserStep, parseStepIO, save ) where + +import Control.Lens ( (^.) ) + +import Data.Aeson ( encodeFile ) +import Data.Text ( pack ) +import Data.Time.Clock ( getCurrentTime ) + +import Environment ( Environment, commit, pullRequest, repoSlug ) + +import Log ( debug, notice, noticeR ) + +import Model ( Benchmark, Test(Test) ) + +import Parser ( State(Failure, Init, Ok) ) + +import qualified ParserGo as Go ( parse ) + +import System.IO.Temp ( emptySystemTempFile ) + +import Text.Printf ( printf ) + +-- | The result of the complete run +type Result = [Benchmark] + +-- | A single parser step consists of an intermediate state and result +type Step = (State, Result) + +-- | Initial parser step for convenience +initParserStep :: Step +initParserStep = (Init, []) + +-- | Go one step forward and log output +parseStepIO :: Step -> String -> IO Step +parseStepIO s line = do + noticeR line + let r = parseStep s line + debugStep r + return r + +-- | Go one step forward by parsing the input String +parseStep :: Step -> String -> Step +parseStep (s, r) i = let ns = Go.parse s i in (ns, appendBenchmark ns r) + +-- | Append the succeeding result if possible +appendBenchmark :: State -> Result -> Result +appendBenchmark (Ok b) r = r ++ pure b +appendBenchmark _ r = r + +-- | Retrieve the amount of benchmark results for the provided Step +amount :: Step -> Int +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 + debugResult r +debugStep (_, r) = debugResult r + +-- | Print a debug message for the current result +debugResult :: Result -> IO () +debugResult r = debug . printf "Current result: %s" $ show r + +-- | Store the current result on disk +toDisk :: (Test, Result) -> IO FilePath +toDisk b = do + f <- emptySystemTempFile "result-.json" + debug $ printf "Writing to temp file: %s" f + encodeFile f b + return f + +-- | Sen the provided data to the given url including the environment +save :: Step -> Environment -> IO () +save (_, r) e = do + t <- getCurrentTime + let d = ( Test t + (pack $ e ^. commit) + (pack $ e ^. repoSlug) + (pack $ e ^. pullRequest) + [] + , r + ) + p <- toDisk d + logFilePath p + return () + +-- | Log the file path convenience function +logFilePath :: FilePath -> IO () +logFilePath p = notice $ printf "You can retry by using the file %s" p diff --git a/src/model b/src/model new file mode 100644 index 0000000..588208d --- /dev/null +++ b/src/model @@ -0,0 +1,15 @@ +Test + time UTCTime + commit Text + repoSlug Text + pullRequest Text + benchmarks [BenchmarkId] + deriving Show + +Benchmark + average Double + derivation Double + name Text + samples Int + unit Text + deriving Show diff --git a/test/ResultSpec.hs b/test/ResultSpec.hs index e9a8306..adc4c40 100644 --- a/test/ResultSpec.hs +++ b/test/ResultSpec.hs @@ -3,7 +3,7 @@ -- @since 0.1.0 module ResultSpec ( resultSpec ) where -import ParserResult ( amount, initParserStep, parseStepIO ) +import Result ( amount, initParserStep, parseStepIO ) import Test.Tasty.Hspec ( Spec, it, parallel, shouldBe )