Separate environment

Signed-off-by: Sascha Grunert <sgrunert@suse.com>
saschagrunert · Jun 24, 2019 · 001beea · 001beea
1 parent 3e5e413
commit 001beea
Show file tree

Hide file tree

Showing 7 changed files with 72 additions and 73 deletions.
diff --git 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
@@ -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/package.yaml b/package.yaml
@@ -20,7 +20,7 @@ flags:
     manual: false
 
 ghc-options:
-  # - -Werror
+  - -Werror
   - -Weverything
   - -Wno-all-missed-specialisations
   - -Wno-implicit-prelude

diff --git a/performabot.cabal b/performabot.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 6dd0c8bb11e5e152228978bd9c385e7a0c7d3f0c96a4d034f60166c3e020325a
+-- hash: e8b55cbf1c21034f18d6b581246cdfd8ae8a3fd0328ee549ddd8172a4a3d2d19
 
 name:           performabot
 version:        0.1.0
@@ -30,7 +30,7 @@ flag static
 
 library
   exposed-modules:
-      Env
+      Environment
       Log
       Model
       Parser
@@ -41,7 +41,7 @@ library
   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
@@ -71,7 +71,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 +91,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 → src/Environment.hs b/src/Env.hs → 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
@@ -5,8 +5,6 @@ module Model
     ( Benchmark(Benchmark)
     , BenchmarkId
     , Entry
-    , Environment(Environment)
-    , EnvironmentId
     , Test(Test)
     , TestId
     , benchmarkAverage
@@ -15,61 +13,37 @@ 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
 
 -- | 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
@@ -8,9 +8,11 @@ import           Control.Exception          ( displayException, try )
 import           Data.Aeson                 ( encodeFile )
 import           Data.ByteString.Lazy.Char8 as C ( unpack )
 
+import           Environment                ( Environment )
+
 import           Log                        ( debug, err, notice, noticeR )
 
-import           Model                      ( Benchmark, Entry, Environment )
+import           Model                      ( Benchmark )
 
 import           Network.HTTP.Simple
                  ( HttpException, Request, getResponseBody
@@ -70,7 +72,7 @@ debugResult :: ParserResult -> IO ()
 debugResult r = debug . printf "Current result: %s" $ show r
 
 -- | Store the current result on disk
-toDisk :: Entry -> IO FilePath
+toDisk :: (Environment, ParserResult) -> IO FilePath
 toDisk b = do
     f <- emptySystemTempFile "result-.json"
     debug $ printf "Writing to temp file: %s" f
@@ -87,7 +89,7 @@ save (_, r) e = do
     doRequest request body p
 
 -- | Do the provided request
-doRequest :: Request -> Entry -> FilePath -> IO ()
+doRequest :: Request -> (Environment, ParserResult) -> FilePath -> IO ()
 doRequest r b p = do
     response <- try . httpLBS $ setRequestBodyJSON b r
     case response of

diff --git a/src/model 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