diff --git a/lib/benchmarks/cardano-wallet-benchmarks.cabal b/lib/benchmarks/cardano-wallet-benchmarks.cabal index 1d145954631..9be89d204b2 100644 --- a/lib/benchmarks/cardano-wallet-benchmarks.cabal +++ b/lib/benchmarks/cardano-wallet-benchmarks.cabal @@ -281,6 +281,7 @@ executable benchmark-history , http-client , http-client-tls , http-media + , http-types , monoidal-containers , optparse-applicative , pretty-simple diff --git a/lib/benchmarks/exe/benchmark-history.hs b/lib/benchmarks/exe/benchmark-history.hs index 55b0ce13d19..ec6aca4ade6 100644 --- a/lib/benchmarks/exe/benchmark-history.hs +++ b/lib/benchmarks/exe/benchmark-history.hs @@ -73,6 +73,9 @@ import Network.HTTP.Client.TLS import Network.HTTP.Media ( (//) ) +import Network.HTTP.Types.Status + ( status410 + ) import Options.Applicative ( Parser , ParserInfo @@ -99,8 +102,9 @@ import Servant.API.ContentTypes import Servant.Client ( BaseUrl (..) , ClientEnv - , ClientError + , ClientError (FailureResponse) , ClientM + , ResponseF (..) , Scheme (..) , client , mkClientEnv @@ -156,8 +160,13 @@ fetchArtifactContent :: WithAuthPipeline (Int -> Text -> Text -> ClientM BL8.ByteString) fetchArtifactContent = client (Proxy :: Proxy (GetArtifact CSV BL8.ByteString)) -queryBuildkite :: Query -> Day -> IO History -queryBuildkite q d0 = +queryBuildkite :: + (forall a . HandleClientError a -> ClientM a -> IO (Maybe a)) + -> (forall a . WithAuthPipeline a -> a) + -> Day -> IO History +queryBuildkite q w d0 = do + let skip410Q = Query (q skip410) w + bailoutQ = Query (q bailout) w S.foldMap_ Prelude.id $ flip S.for @@ -166,7 +175,9 @@ queryBuildkite q d0 = Left e -> error e ) $ flip S.for historyPoints - $ flip S.for (\(a, j) -> getArtifactsContent q fetchArtifactContent j a) + $ flip S.for (\(a, j) -> getArtifactsContent + skip410Q + fetchArtifactContent j a) $ S.chain ( \(_, b) -> putStrLn @@ -178,8 +189,8 @@ queryBuildkite q d0 = $ S.filter (\(a, _) -> "bench-results.csv" `isSuffixOf` filename a) $ S.map (\(b, a) -> (a, b)) - $ flip S.for (getArtifacts q) - $ getReleaseCandidateBuilds q d0 + $ flip S.for (getArtifacts bailoutQ) + $ getReleaseCandidateBuilds bailoutQ d0 mkReleaseCandidateName :: Day -> String mkReleaseCandidateName d = "release-candidate/v" ++ show d @@ -224,15 +235,17 @@ optionsParser = <> header "benchmark-history - a tool for benchmark data analysis" ) +type HandleClientError a = IO (Either ClientError a) -> IO (Maybe a) + main :: IO () main = do bkToken <- getToken Options sinceDay outputDir <- execParser optionsParser manager <- newManager $ specialSettings False let env = buildkiteEnv manager - runQuery action = bailout $ runClientM action env - query = Query runQuery $ withAuthWallet bkToken - result <- queryBuildkite query sinceDay + runQuery :: HandleClientError a -> ClientM a -> IO (Maybe a) + runQuery f action = f $ runClientM action env + result <- queryBuildkite runQuery (withAuthWallet bkToken) sinceDay let eHarmonized = harmonizeHistory result case eHarmonized of Left rs -> error $ "Failed to harmonize history: " ++ show rs @@ -242,12 +255,21 @@ main = do BL8.writeFile (outputDir "benchmark_history" <.> "csv") csv renderHarmonizedHistoryChartSVG outputDir harmonized -bailout :: IO (Either ClientError a) -> IO a -bailout f = do +bailout :: HandleClientError a +bailout = handle (error . show) + +handle :: (ClientError -> IO (Maybe a)) -> HandleClientError a +handle g f = do res <- f case res of - Left e -> error $ show e - Right a -> pure a + Left e -> g e + Right a -> pure $ Just a + +skip410 :: HandleClientError a +skip410 = handle $ \case + FailureResponse _ (Response s _ _ _) + | s == status410 -> pure Nothing + e -> error $ show e buildkiteEnv :: Manager -> ClientEnv buildkiteEnv manager = diff --git a/lib/buildkite/src/Buildkite/Client.hs b/lib/buildkite/src/Buildkite/Client.hs index eb0a988bb89..3c08890a7bc 100644 --- a/lib/buildkite/src/Buildkite/Client.hs +++ b/lib/buildkite/src/Buildkite/Client.hs @@ -64,8 +64,9 @@ import qualified Streaming.Prelude as S data Query = Query - (forall a. ClientM a -> IO a) - (forall a. WithAuthPipeline a -> a) + { query :: forall a. ClientM a -> IO (Maybe a) + , withAuth :: forall a. WithAuthPipeline a -> a + } type JobMap = Map Text Job @@ -73,15 +74,20 @@ type BuildJobsMap = BKAPI.Build (Map Text) type BuildAPI = BKAPI.Build [] -paging :: Monad m => (Maybe Int -> m [a]) -> Stream (Of a) m () +paging :: Monad m => (Maybe Int -> m (Maybe [a])) + -> Stream (Of a) m () paging f = go 1 where go page = do - bs <- lift $ f $ Just page - S.each bs - case bs of - [] -> pure () - _ -> go $ page + 1 + mbs <- lift $ f $ Just page + case mbs of + Nothing -> + pure () -- arbitrary choice ? + Just bs -> do + S.each bs + case bs of + [] -> pure () + _ -> go $ page + 1 getBuilds :: Query -> Stream (Of BuildAPI) IO () getBuilds (Query q w) = paging $ q . w fetchBuilds @@ -110,7 +116,7 @@ getArtifactsContent -> Artifact -> Stream (Of (BuildJobsMap, Artifact, r)) IO () getArtifactsContent (Query q w) getArtifact build artifact = do - benchResults <- + mBenchResults <- do lift $ q $ w @@ -118,7 +124,9 @@ getArtifactsContent (Query q w) getArtifact build artifact = do (number build) (job_id artifact) (BKAPI.artifactId artifact) - S.yield (build, artifact, benchResults) + case mBenchResults of + Nothing -> pure () + Just benchResults -> S.yield (build, artifact, benchResults) downloadArtifact :: ArtifactURL -> Stream (Of BL.ByteString) IO () downloadArtifact (ArtifactURL url') = do