diff --git a/config/models.persistentmodels b/config/models.persistentmodels index fd1b79b..a8ff551 100644 --- a/config/models.persistentmodels +++ b/config/models.persistentmodels @@ -1,6 +1,6 @@ Test - benchmarks [Benchmark] - environment Environment + benchmarks [BenchmarkId] + environment EnvironmentId time UTCTime deriving Show diff --git a/nix/shell.nix b/nix/shell.nix index 64eb8d1..fdbedaf 100644 --- a/nix/shell.nix +++ b/nix/shell.nix @@ -14,6 +14,7 @@ pkgs.stdenv.mkDerivation { hlint nix-prefetch-git sass + sqlite wget zlib ]; diff --git a/src/Handler/Api.hs b/src/Handler/Api.hs index 60e1fa1..4afa684 100644 --- a/src/Handler/Api.hs +++ b/src/Handler/Api.hs @@ -6,6 +6,7 @@ module Handler.Api ( getApiR, postApiR ) where import Data.Aeson.Types as T ( Result(Success) ) +import Data.Time.Clock ( getCurrentTime ) import Import @@ -14,7 +15,12 @@ getApiR = return $ String "Hello world" postApiR :: Handler () postApiR = do - body <- parseCheckJsonBody :: Handler (T.Result Test) + body <- parseCheckJsonBody :: Handler (T.Result ReqBody) case body of - Success _ -> sendResponseStatus status200 () + Success (e, b) -> do + eId <- runDB $ insert e + bIds <- runDB $ mapM insert b + time <- liftIO getCurrentTime + _ <- runDB . insertEntity $ Test bIds eId time + sendResponseStatus status200 () _ -> sendResponseStatus status400 () diff --git a/src/Model.hs b/src/Model.hs index f62d304..170eab7 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -6,6 +6,7 @@ module Model ( Benchmark(Benchmark) , BenchmarkId + , ReqBody , Environment(Environment) , EnvironmentId , Test(Test) @@ -41,6 +42,8 @@ share [ mkPersist sqlSettings { mpsGenerateLenses = True } ] $(persistFileWith lowerCaseSettings "config/models.persistentmodels") +type ReqBody = (Environment, [Benchmark]) + -- | Drop the "_benchmark" from the Benchmark deriveJSON defaultOptions { fieldLabelModifier = drop 10 } ''Benchmark diff --git a/src/ParserResult.hs b/src/ParserResult.hs index 67b14af..40fc5e8 100644 --- a/src/ParserResult.hs +++ b/src/ParserResult.hs @@ -7,14 +7,12 @@ import Control.Exception ( displayException, try ) import Data.Aeson ( encodeFile ) import Data.ByteString.Lazy.Char8 as C ( unpack ) -import Data.Time.Clock ( getCurrentTime ) import GoParser ( parse ) import Log ( debug, err, notice, noticeR ) -import Model - ( Benchmark, Environment, Test(Test) ) +import Model ( Benchmark, Environment, ReqBody ) import Network.HTTP.Simple ( HttpException, Request, getResponseBody @@ -72,30 +70,26 @@ debugResult :: ParserResult -> IO () debugResult r = debug . printf "Current result: %s" $ show r -- | Store the current result on disk -toDisk :: Test -> IO FilePath -toDisk t = do +toDisk :: ReqBody -> IO FilePath +toDisk b = do f <- emptySystemTempFile "result-.json" debug $ printf "Writing to temp file: %s" f - encodeFile f t + encodeFile f b return f --- | Convert a parser result and a given environment to a test model -toTest :: ParserResult -> Environment -> IO Test -toTest r e = Test r e <$> getCurrentTime - -- | Sen the provided data to the given url including the environment send :: ParserStep -> String -> Environment -> IO () send (_, r) u e = do - t <- toTest r e - p <- toDisk t + let body = (e, r) + p <- toDisk body request <- buildRequest u p debug . printf "Doing HTTP request:\n%s" $ show request - doRequest request t p + doRequest request body p -- | Do the provided request -doRequest :: Request -> Test -> FilePath -> IO () -doRequest r t p = do - response <- try . httpLBS $ setRequestBodyJSON t r +doRequest :: Request -> ReqBody -> FilePath -> IO () +doRequest r b p = do + response <- try . httpLBS $ setRequestBodyJSON b r case response of Right res -> case getResponseStatusCode res of 200 -> do