diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,9 +5,11 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). -## 0.3.6.1 - 2024-01-23 +## 0.3.7 - 2024-02-12 -Maintenance release. +### Fixed + + - `hci state` Commands are now more robust, retrying when HTTP requests fail ## 0.3.6 - 2023-03-07 diff --git a/hercules-ci-cli.cabal b/hercules-ci-cli.cabal --- a/hercules-ci-cli.cabal +++ b/hercules-ci-cli.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: hercules-ci-cli -version: 0.3.6.1 +version: 0.3.7 synopsis: The hci command for working with Hercules CI homepage: https://docs.hercules-ci.com bug-reports: https://github.com/hercules-ci/hercules-ci-agent/issues @@ -84,6 +84,7 @@ , servant-client-core , temporary , text + , tls , transformers , transformers-base , unix diff --git a/src/Hercules/CLI/Client.hs b/src/Hercules/CLI/Client.hs --- a/src/Hercules/CLI/Client.hs +++ b/src/Hercules/CLI/Client.hs @@ -1,10 +1,38 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -O0 #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Hercules.CLI.Client where +module Hercules.CLI.Client + ( -- * Setup + determineDefaultApiBaseUrl, + init, + -- * Using the client + HerculesClientToken (..), + HerculesClientEnv, + retryOnFail, + retryOnFailAnon, + retryStreamOnFail, + + -- * Error handling + shouldRetryClientError, + clientErrorSummary, + shouldRetryResponse, + waitRetryPolicy, + dieWithHttpError, + prettyPrintHttpErrors, + + -- * Client function groups + accountsClient, + projectsClient, + reposClient, + stateClient, + ) +where + -- TODO https://github.com/haskell-servant/servant/issues/986 import Data.Has (Has, getter) @@ -15,8 +43,10 @@ import Hercules.API.Repos (ReposAPI) import Hercules.API.State (ContentDisposition, ContentLength, RawBytes, StateAPI) import Hercules.Error +import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS -import Network.HTTP.Types.Status +import Network.HTTP.Types.Status (Status (statusCode, statusMessage)) +import qualified Network.TLS as TLS import Protolude import RIO (RIO) import Servant.API @@ -29,18 +59,8 @@ import Servant.Client.Streaming (ClientM, responseStatusCode, showBaseUrl) import qualified Servant.Client.Streaming import qualified System.Environment - --- | Bad instance to make it the client for State api compile. GHC seems to pick --- the wrong overlappable instance. -instance - FromSourceIO - RawBytes - ( Headers - '[ContentLength, ContentDisposition] - (SourceIO RawBytes) - ) - where - fromSourceIO = addHeader (-1) . addHeader "" . fromSourceIO +import qualified UnliftIO +import UnliftIO.Retry (RetryPolicyM, RetryStatus, capDelay, fullJitterBackoff, retrying, rsIterNumber) client :: ClientAPI ClientAuth (AsClientT ClientM) client = fromServant $ Servant.Client.Streaming.client (servantClientApi @ClientAuth) @@ -70,11 +90,6 @@ newtype HerculesClientToken = HerculesClientToken Token -runHerculesClient :: (NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) => (Token -> Servant.Client.Streaming.ClientM a) -> RIO r a -runHerculesClient f = do - HerculesClientToken token <- asks getter - runHerculesClient' $ f token - runHerculesClientEither :: (NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) => (Token -> Servant.Client.Streaming.ClientM a) -> RIO r (Either Servant.Client.Streaming.ClientError a) runHerculesClientEither f = do HerculesClientToken token <- asks getter @@ -88,15 +103,18 @@ runHerculesClientStream f g = do HerculesClientToken token <- asks getter HerculesClientEnv clientEnv <- asks getter - liftIO $ Servant.Client.Streaming.withClientM (f token) clientEnv g + liftIO $ convertInternalError $ Servant.Client.Streaming.withClientM (f token) clientEnv g runHerculesClient' :: (NFData a, Has HerculesClientEnv r) => Servant.Client.Streaming.ClientM a -> RIO r a runHerculesClient' = runHerculesClientEither' >=> escalate +retryOnFailAnon :: (NFData b, Has HerculesClientEnv r) => Text -> ClientM b -> RIO r b +retryOnFailAnon shortDesc m = retryOnFailEither shortDesc (UnliftIO.try $ runHerculesClient' m) >>= escalate + runHerculesClientEither' :: (NFData a, Has HerculesClientEnv r) => Servant.Client.Streaming.ClientM a -> RIO r (Either Servant.Client.Streaming.ClientError a) runHerculesClientEither' m = do HerculesClientEnv clientEnv <- asks getter - liftIO (Servant.Client.Streaming.runClientM m clientEnv) + liftIO $ convertInternalError $ Servant.Client.Streaming.runClientM m clientEnv init :: IO HerculesClientEnv init = do @@ -130,7 +148,7 @@ -- | Low indicating the inclusiveness of the boundaries. Low is included. High is excluded. -- A pair where `fst` > `snd` forms an empty range. -inLowRange :: Ord a => a -> (a, a) -> Bool +inLowRange :: (Ord a) => a -> (a, a) -> Bool a `inLowRange` (p, q) = a >= p && a < q -- In a library, this should support 429 with Retry-After @@ -152,6 +170,42 @@ shouldRetryClientError (ClientError.ConnectionError _) = True shouldRetryClientError _ = False +-- | A custom exception type for HTTP exceptions that we consider retryable. +data HTTPInternalException = HTTPInternalException HTTP.Request SomeException + deriving (Exception, Show) + +-- | Convert a missed HTTP exception into a ClientError. +-- This is useful for retrying. +convertInternalError :: IO a -> IO a +convertInternalError = deescalateInternalError >=> escalate + +deescalateInternalError :: IO a -> IO (Either ClientError a) +deescalateInternalError m = handleJust matchClientException (pure . Left) (Right <$> m) + where + matchClientException = + fromException >=> \case + HTTP.HttpExceptionRequest req (HTTP.InternalException e) + | isJust (isRetryableHTTPInternalException e) -> + Just $ ClientError.ConnectionError $ toException $ HTTPInternalException req $ toException e + _ -> Nothing + isRetryableHTTPInternalException = + fromException >=> \e -> case e of + TLS.Terminated _mysteryBool _msg tlsError + | isRetryableTLSError tlsError -> + pass + _ -> Nothing + -- Error_Protocol has been observed. Most others are probably also worth retrying. + -- https://hackage.haskell.org/package/tls-1.9.0/docs/Network-TLS.html#t:TLSError + -- real world example: Error_Protocol ("remote side fatal error",True,BadRecordMac)) + isRetryableTLSError = + \case + TLS.Error_Protocol {} -> True + TLS.Error_EOF {} -> True + TLS.Error_Packet {} -> True + TLS.Error_Packet_unexpected {} -> True + TLS.Error_Packet_Parsing {} -> True + _ -> False + -- | ClientError printer that won't leak sensitive info. clientErrorSummary :: ClientError -> Text clientErrorSummary (ClientError.FailureResponse _ resp) = "status " <> show (responseStatusCode resp) @@ -159,3 +213,48 @@ clientErrorSummary ClientError.UnsupportedContentType {} = "unsupported content type" clientErrorSummary ClientError.InvalidContentTypeHeader {} = "invalid content type header" clientErrorSummary (ClientError.ConnectionError e) = "connection error: " <> show e + +simpleRetryPredicate :: (Applicative m) => (r -> Bool) -> RetryStatus -> r -> m Bool +simpleRetryPredicate f _rs r = pure (f r) + +retryStreamOnFail :: + (Has HerculesClientToken r, Has HerculesClientEnv r) => + Text -> + (Token -> ClientM b) -> + (Either ClientError b -> IO c) -> + RIO r c +retryStreamOnFail shortDesc req handler = escalate =<< retryOnFailEither shortDesc (UnliftIO.try (runHerculesClientStream req handler)) + +retryOnFail :: + (NFData b, Has HerculesClientToken r, Has HerculesClientEnv r) => + Text -> + (Token -> ClientM b) -> + RIO r b +retryOnFail shortDesc req = escalate =<< retryOnFailEither shortDesc (runHerculesClientEither req) + +retryOnFailEither :: + Text -> + RIO r (Either ClientError a) -> + RIO r (Either ClientError a) +retryOnFailEither shortDesc req = + retrying + failureRetryPolicy + (simpleRetryPredicate shouldRetryResponse) + ( \rs -> do + when (rsIterNumber rs /= 0) do + liftIO $ putErrText $ "hci: " <> shortDesc <> " retrying." + r <- req + for_ (leftToMaybe r) \e -> do + liftIO $ putErrText $ "hci: " <> shortDesc <> " encountered " <> clientErrorSummary e <> "." + when (shouldRetryClientError e) do + liftIO $ putErrText $ "hci: " <> shortDesc <> " will retry." + pure r + ) + +-- NB: fullJitterBackoff is not what it says it is: https://github.com/Soostone/retry/issues/46 +failureRetryPolicy :: (MonadIO m) => RetryPolicyM m +failureRetryPolicy = capDelay (120 * 1000 * 1000) (fullJitterBackoff 100000) + +-- NB: fullJitterBackoff is not what it says it is: https://github.com/Soostone/retry/issues/46 +waitRetryPolicy :: (MonadIO m) => RetryPolicyM m +waitRetryPolicy = capDelay (10 * 1000 * 1000) (fullJitterBackoff 500000) diff --git a/src/Hercules/CLI/Effect.hs b/src/Hercules/CLI/Effect.hs --- a/src/Hercules/CLI/Effect.hs +++ b/src/Hercules/CLI/Effect.hs @@ -19,7 +19,7 @@ import qualified Hercules.Agent.NixFile.GitSource as GitSource import qualified Hercules.Agent.NixFile.HerculesCIArgs as HerculesCIArgs import Hercules.Agent.Sensitive (Sensitive (Sensitive)) -import Hercules.CLI.Client (HerculesClientEnv, HerculesClientToken, determineDefaultApiBaseUrl, projectsClient, runHerculesClient) +import Hercules.CLI.Client (HerculesClientEnv, HerculesClientToken, determineDefaultApiBaseUrl, projectsClient, retryOnFail) import Hercules.CLI.Common (runAuthenticatedOrDummy) import Hercules.CLI.Exception (exitMsg) import Hercules.CLI.Git (getAllBranches, getHypotheticalRefs) @@ -118,7 +118,8 @@ runEffectSecretContext = secretContextMaybe, runEffectUseNixDaemonProxy = False, -- FIXME Enable proxy for ci/dev parity. Requires access to agent binaries. Unified executable? runEffectExtraNixOptions = [], - runEffectFriendly = True + runEffectFriendly = True, + runEffectConfiguredMountables = mempty -- FIXME: provide hosts? } throwIO exitCode @@ -177,7 +178,7 @@ drvPath <- getDrvFile evalState (rtValue effectAttrs) liftIO $ CNix.getDerivation store drvPath -prepareDerivation :: MonadIO m => Store -> Derivation -> m () +prepareDerivation :: (MonadIO m) => Store -> Derivation -> m () prepareDerivation store derivation = do inputs <- liftIO $ getDerivationInputs store derivation storePathsWithOutputs <- liftIO Std.Vector.new @@ -221,7 +222,7 @@ Just x -> pure x Nothing -> do exitMsg $ "Can not access " <> show path <> ". Make sure you have installed Hercules CI on the organization and repository and that you have access to it." - response <- runHerculesClient (Projects.createUserEffectToken projectsClient projectId) + response <- retryOnFail "create user effect token" (Projects.createUserEffectToken projectsClient projectId) let token = Sensitive (CreateUserEffectTokenResponse.token response) pure ProjectData {pdProjectPath = Just path, pdProjectId = Just $ Id $ idUUID projectId, pdToken = Just token} else diff --git a/src/Hercules/CLI/Exception.hs b/src/Hercules/CLI/Exception.hs --- a/src/Hercules/CLI/Exception.hs +++ b/src/Hercules/CLI/Exception.hs @@ -16,5 +16,5 @@ exitFailure ) -exitMsg :: MonadIO m => Text -> m a +exitMsg :: (MonadIO m) => Text -> m a exitMsg = liftIO . throwIO . UserException diff --git a/src/Hercules/CLI/JSON.hs b/src/Hercules/CLI/JSON.hs --- a/src/Hercules/CLI/JSON.hs +++ b/src/Hercules/CLI/JSON.hs @@ -189,25 +189,25 @@ Left _e -> throwIO $ UserException $ "File " <> show file <> " for key " <> key <> " is not valid UTF-8." Right s -> pure (key, s) -readJsonFileWithKey :: FromJSON b => (Text, FilePath) -> IO (Text, b) +readJsonFileWithKey :: (FromJSON b) => (Text, FilePath) -> IO (Text, b) readJsonFileWithKey (key, file) = do bs <- BS.readFile file case eitherDecode (BL.fromStrict bs) of Left e -> throwIO $ UserException $ "File " <> show file <> " for key " <> key <> " is not valid JSON: " <> show e Right s -> pure (key, s) -readJsonFile :: FromJSON b => FilePath -> IO b +readJsonFile :: (FromJSON b) => FilePath -> IO b readJsonFile file = do bs <- BS.readFile file case eitherDecode (BL.fromStrict bs) of Left e -> throwIO $ UserException $ "File " <> show file <> " is not valid JSON: " <> show e Right s -> pure s -writeJsonFile :: ToJSON a => FilePath -> a -> IO () +writeJsonFile :: (ToJSON a) => FilePath -> a -> IO () writeJsonFile filePath v = atomicWriteFile filePath $ BL.toStrict $ encodePretty' prettyConf v -printJson :: ToJSON a => a -> IO () +printJson :: (ToJSON a) => a -> IO () printJson = BS.putStr . BL.toStrict . (<> "\n") . encodePretty' prettyConf prettyConf :: Data.Aeson.Encode.Pretty.Config diff --git a/src/Hercules/CLI/Lock.hs b/src/Hercules/CLI/Lock.hs --- a/src/Hercules/CLI/Lock.hs +++ b/src/Hercules/CLI/Lock.hs @@ -6,7 +6,7 @@ module Hercules.CLI.Lock (commandParser) where import Control.Monad.IO.Unlift (UnliftIO (UnliftIO), askUnliftIO) -import Control.Retry (RetryPolicyM, RetryStatus, capDelay, fullJitterBackoff, retrying, rsIterNumber) +import Control.Retry (retrying) import Data.Aeson.Encode.Pretty (encodePretty) import Data.Has (Has) import Data.IORef (IORef) @@ -25,12 +25,11 @@ import qualified Hercules.API.State.StateLockAcquireResponse as StateLockAcquireResponse import qualified Hercules.API.State.StateLockLease as StateLockLease import qualified Hercules.API.State.StateLockUpdateRequest as StateLockUpdateRequest -import Hercules.CLI.Client (HerculesClientEnv, HerculesClientToken, clientErrorSummary, determineDefaultApiBaseUrl, runHerculesClientEither, shouldRetryClientError, shouldRetryResponse, stateClient) +import Hercules.CLI.Client (HerculesClientEnv, HerculesClientToken, determineDefaultApiBaseUrl, retryOnFail, stateClient, waitRetryPolicy) import Hercules.CLI.Common (runAuthenticated) import Hercules.CLI.Options (mkCommand) import Hercules.CLI.Project (projectOption) import Hercules.CLI.State (getProjectAndClient) -import Hercules.Error (escalate) import Hercules.Frontend (mkLinks) import qualified Hercules.Frontend import qualified Network.URI @@ -39,7 +38,6 @@ import Protolude import RIO (RIO) import Servant.Auth.Client (Token) -import Servant.Client.Core (ClientError) import Servant.Client.Internal.HttpClient.Streaming (ClientM) import qualified System.Environment import qualified System.Process @@ -174,44 +172,6 @@ putErrText "hci: lock released" liftIO $ exitWith exitCode -simpleRetryPredicate :: Applicative m => (r -> Bool) -> RetryStatus -> r -> m Bool -simpleRetryPredicate f _rs r = pure (f r) - -retryOnFail :: - (NFData b, Has HerculesClientToken r, Has HerculesClientEnv r) => - Text -> - (Token -> ClientM b) -> - RIO r b -retryOnFail shortDesc req = escalate =<< retryOnFailEither shortDesc req - -retryOnFailEither :: - (NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) => - Text -> - (Token -> ClientM a) -> - RIO r (Either ClientError a) -retryOnFailEither shortDesc req = - retrying - failureRetryPolicy - (simpleRetryPredicate shouldRetryResponse) - ( \rs -> do - when (rsIterNumber rs /= 0) do - liftIO $ putErrText $ "hci: " <> shortDesc <> " retrying." - r <- runHerculesClientEither req - for_ (leftToMaybe r) \e -> do - liftIO $ putErrText $ "hci: " <> shortDesc <> " encountered " <> clientErrorSummary e <> "." - when (shouldRetryClientError e) do - liftIO $ putErrText $ "hci: " <> shortDesc <> " will retry." - pure r - ) - --- NB: fullJitterBackoff is broken, https://github.com/Soostone/retry/issues/46 -failureRetryPolicy :: MonadIO m => RetryPolicyM m -failureRetryPolicy = capDelay (120 * 1000 * 1000) (fullJitterBackoff 100000) - --- NB: fullJitterBackoff is broken, https://github.com/Soostone/retry/issues/46 -waitRetryPolicy :: MonadIO m => RetryPolicyM m -waitRetryPolicy = capDelay (10 * 1000 * 1000) (fullJitterBackoff 500000) - tryAcquire :: (Has HerculesClientToken r, Has HerculesClientEnv r) => IORef (Maybe StateLockAcquireResponse.StateLockBlockedResponse) -> @@ -245,7 +205,7 @@ Acquired s -> pure s logBlockedMaybe :: - MonadIO m => + (MonadIO m) => IORef (Maybe StateLockAcquireResponse.StateLockBlockedResponse) -> StateLockAcquireResponse.StateLockBlockedResponse -> m () @@ -255,7 +215,7 @@ writeIORef ref (Just resp) logBlocked resp -logBlocked :: MonadIO m => StateLockAcquireResponse.StateLockBlockedResponse -> m () +logBlocked :: (MonadIO m) => StateLockAcquireResponse.StateLockBlockedResponse -> m () logBlocked s = do putErrText "hci: lock blocked" for_ (StateLockAcquireResponse.blockedByLeases s) \lease -> do diff --git a/src/Hercules/CLI/Login.hs b/src/Hercules/CLI/Login.hs --- a/src/Hercules/CLI/Login.hs +++ b/src/Hercules/CLI/Login.hs @@ -26,7 +26,7 @@ username <- getLoginName clientEnv <- Hercules.CLI.Client.init runRIO ((), clientEnv) do - r <- runHerculesClient' do + r <- retryOnFailAnon "get authorization request" do Accounts.postCLIAuthorizationRequest accountsClient CLIAuthorizationRequestCreate @@ -38,7 +38,7 @@ let tmpTok = CLIAuthorizationRequestCreateResponse.temporaryCLIToken r -- TODO do something pretty with 404 pollLoop = do - s <- runHerculesClient' do + s <- retryOnFailAnon "check authorization request status" do Accounts.getCLIAuthorizationRequestStatus accountsClient tmpTok case CLIAuthorizationRequestStatus.status s of CLIAuthorizationRequestStatus.Pending {} -> do diff --git a/src/Hercules/CLI/Main.hs b/src/Hercules/CLI/Main.hs --- a/src/Hercules/CLI/Main.hs +++ b/src/Hercules/CLI/Main.hs @@ -41,7 +41,7 @@ Hercules.CNix.init Hercules.CNix.Util.installDefaultSigINTHandler -addNix :: Functor f => f (IO a) -> f (IO a) +addNix :: (Functor f) => f (IO a) -> f (IO a) addNix = fmap (initNix *>) prettyPrintErrors :: IO a -> IO a diff --git a/src/Hercules/CLI/Nix.hs b/src/Hercules/CLI/Nix.hs --- a/src/Hercules/CLI/Nix.hs +++ b/src/Hercules/CLI/Nix.hs @@ -16,7 +16,7 @@ import qualified Hercules.Agent.NixFile.GitSource as GitSource import Hercules.Agent.NixFile.HerculesCIArgs (CISystems (CISystems), HerculesCIArgs) import qualified Hercules.Agent.NixFile.HerculesCIArgs as HerculesCIArgs -import Hercules.CLI.Client (HerculesClientEnv, HerculesClientToken, determineDefaultApiBaseUrl, runHerculesClient) +import Hercules.CLI.Client (HerculesClientEnv, HerculesClientToken, determineDefaultApiBaseUrl, retryOnFail) import Hercules.CLI.Common (runAuthenticated) import Hercules.CLI.Git (getGitRoot, getRef, getRev, getUpstreamURL, guessForgeTypeFromURL) import Hercules.CLI.Options (scanOption) @@ -75,7 +75,7 @@ resolveInput _name (SiblingInput input) = unliftIO uio do let resourceClient = projectResourceClientByPath (projectPath {projectPathProject = InputDeclaration.project input}) jobNames = [] - immutableGitInput <- runHerculesClient (getJobSource resourceClient (InputDeclaration.ref input) jobNames) + immutableGitInput <- retryOnFail "get job source" (getJobSource resourceClient (InputDeclaration.ref input) jobNames) liftIO $ mkImmutableGitInputFlakeThunk evalState immutableGitInput resolveInput _name InputDeclaration.BogusInput {} = panic "resolveInput: not implemented yet" inputs diff --git a/src/Hercules/CLI/Project.hs b/src/Hercules/CLI/Project.hs --- a/src/Hercules/CLI/Project.hs +++ b/src/Hercules/CLI/Project.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE TypeFamilies #-} module Hercules.CLI.Project where @@ -14,7 +15,7 @@ import qualified Hercules.API.Projects.Project as Project import qualified Hercules.API.Repos as Repos import qualified Hercules.API.Repos.RepoKey as RepoKey -import Hercules.CLI.Client (HerculesClientEnv, HerculesClientToken, projectsClient, reposClient, runHerculesClient, runHerculesClientEither) +import Hercules.CLI.Client (HerculesClientEnv, HerculesClientToken, projectsClient, reposClient, retryOnFail) import Hercules.CLI.Common (exitMsg) import qualified Hercules.CLI.Git as Git import Hercules.CLI.Options (attoparsecReader, packSome) @@ -28,6 +29,7 @@ import Servant.Client.Core.Response (ResponseF (Response)) import Servant.Client.Generic (AsClientT) import Servant.Client.Streaming (ClientM) +import UnliftIO (catch) import UnliftIO.Environment (lookupEnv) import qualified Prelude @@ -85,7 +87,8 @@ findProjectByKey :: (Has HerculesClientToken r, Has HerculesClientEnv r) => ProjectPath -> RIO r (Maybe Project.Project) findProjectByKey path = - runHerculesClient + retryOnFail + "find project" ( Projects.findProjects projectsClient (Just $ Name $ projectPathSite path) @@ -108,25 +111,25 @@ findProjectByCurrentRepo :: (Has HerculesClientToken r, Has HerculesClientEnv r) => RIO r (Maybe (Id Project), ProjectPath) findProjectByCurrentRepo = do url <- liftIO Git.getUpstreamURL - rs <- runHerculesClientEither (Repos.parseGitURL reposClient url) - case rs of - Left (FailureResponse _req Response {responseStatusCode = Status {statusCode = 404}}) -> do - exitMsg "Repository not recognized by Hercules CI. Make sure you're in the right repository, and if you're running Hercules CI Enterprise, make sure you're using the right HERCULES_CI_API_BASE_URL. Alternatively, use the --project option." - Left e -> throwIO e - Right r -> - pure - ( RepoKey.projectId r, - ProjectPath - { projectPathSite = RepoKey.siteName r, - projectPathOwner = RepoKey.ownerName r, - projectPathProject = RepoKey.repoName r - } - ) + r <- + retryOnFail "parse-git-url" (Repos.parseGitURL reposClient url) `UnliftIO.catch` \case + (FailureResponse _req Response {responseStatusCode = Status {statusCode = 404}}) -> do + exitMsg "Repository not recognized by Hercules CI. Make sure you're in the right repository, and if you're running Hercules CI Enterprise, make sure you're using the right HERCULES_CI_API_BASE_URL. Alternatively, use the --project option." + e -> throwIO e + pure + ( RepoKey.projectId r, + ProjectPath + { projectPathSite = RepoKey.siteName r, + projectPathOwner = RepoKey.ownerName r, + projectPathProject = RepoKey.repoName r + } + ) findProject :: (Has HerculesClientToken r, Has HerculesClientEnv r) => ProjectPath -> RIO r Project.Project findProject project = do rs <- - runHerculesClient + retryOnFail + "find project" ( findProjects projectsClient (Just $ Name $ projectPathSite project) diff --git a/src/Hercules/CLI/State.hs b/src/Hercules/CLI/State.hs --- a/src/Hercules/CLI/State.hs +++ b/src/Hercules/CLI/State.hs @@ -1,11 +1,17 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Hercules.CLI.State (commandParser, getProjectAndClient) where -import Conduit (ConduitT, mapC, runConduitRes, sinkFile, sourceHandle, stdinC, stdoutC, (.|)) +import Conduit (mapC, runConduitRes, sinkLazyBuilder, (.|)) +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as BL import Data.Has (Has) -import Hercules.API (ClientAuth, enterApiE) +import Hercules.API (ClientAuth, NoContent, enterApiE) import Hercules.API.Name (Name (Name)) import Hercules.API.State import Hercules.CLI.Client @@ -15,11 +21,14 @@ import Options.Applicative (auto, bashCompleter, completer, help, long, metavar, option, strOption) import qualified Options.Applicative as Optparse import Protolude -import RIO (RIO, runRIO, withBinaryFile) -import Servant.API (Headers (Headers), fromSourceIO, toSourceIO) +import RIO (RIO) +import qualified RIO.ByteString as BS +import Servant.API (HList (HCons), Headers (Headers), ResponseHeader (Header), fromSourceIO) +import Servant.Client (ClientError (ConnectionError)) import Servant.Client.Generic (AsClientT) import Servant.Client.Internal.HttpClient.Streaming (ClientM) import Servant.Conduit () +import qualified Servant.Types.SourceT as Servant commandParser, getCommandParser, putCommandParser :: Optparse.Parser (IO ()) commandParser = @@ -42,13 +51,27 @@ runAuthenticated do projectStateClient <- getProjectAndClient projectMaybe -- TODO: version - runHerculesClientStream (getStateData projectStateClient name versionMaybe) \case - Left e -> dieWithHttpError e - Right (Headers r _) -> do - runConduitRes $ - fromSourceIO r .| mapC fromRawBytes .| case file of - "-" -> stdoutC - _ -> sinkFile file + bytes <- retryStreamOnFail "state get" (\token -> getStateData projectStateClient name versionMaybe token) \case + Left e -> throwIO e + Right (Headers stream headers) -> do +#if MIN_VERSION_servant(0,20,0) + s <- fromSourceIO stream +#else + let s = fromSourceIO stream +#endif + bl <- runConduitRes $ s .| mapC (BB.byteString . fromRawBytes) .| sinkLazyBuilder + let lenH :: ResponseHeader "Content-Length" Integer + lenH `HCons` _ = headers + actual = fromIntegral $ BL.length bl + case lenH of + Header expected -> + when (actual /= expected) do + throwIO $ ConnectionError $ toException $ FatalError $ "Expected " <> show expected <> " bytes, but got " <> show actual + _ -> pass + pure (BL.toStrict bl) + case file of + "-" -> BS.putStr bytes + _ -> BS.writeFile file bytes putCommandParser = do projectMaybe <- optional projectOption name <- nameOption @@ -56,17 +79,12 @@ pure do runAuthenticated do projectStateClient <- getProjectAndClient projectMaybe - let withStream :: (ConduitT a RawBytes IO () -> RIO r b) -> RIO r b - withStream = case file of - "-" -> ($ (stdinC .| mapC RawBytes)) - _ -> \f -> do - r <- ask - liftIO $ withBinaryFile file ReadMode \h -> - runRIO r $ f (sourceHandle h .| mapC RawBytes) - withStream \stream -> do - _noContent <- runHerculesClient (putStateData projectStateClient name (toSourceIO stream)) - pass - putErrText $ "hci: State file upload successful for " <> name + bytes <- case file of + "-" -> BS.getContents + _ -> BS.readFile file + _ :: NoContent <- retryOnFail "state put" do + putStateData projectStateClient name (Servant.source [RawBytes bytes]) + putErrText $ "hci: State file upload successful for " <> name nameOption :: Optparse.Parser Text nameOption = strOption $ long "name" <> metavar "NAME" <> help "Name of the state file"