hercules-ci-cli 0.3.6.1 → 0.3.7

raw patch · 12 files changed

+206/−122 lines, 12 filesdep +tlsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: tls

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−2
• hercules-ci-cli.cabal +2/−1
• src/Hercules/CLI/Client.hs +121/−22
• src/Hercules/CLI/Effect.hs +5/−4
• src/Hercules/CLI/Exception.hs +1/−1
• src/Hercules/CLI/JSON.hs +4/−4
• src/Hercules/CLI/Lock.hs +4/−44
• src/Hercules/CLI/Login.hs +2/−2
• src/Hercules/CLI/Main.hs +1/−1
• src/Hercules/CLI/Nix.hs +2/−2
• src/Hercules/CLI/Project.hs +20/−17
• src/Hercules/CLI/State.hs +40/−22

@@ -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 

@@ -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

@@ -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)

@@ -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

@@ -16,5 +16,5 @@         exitFailure     ) -exitMsg :: MonadIO m => Text -> m a+exitMsg :: (MonadIO m) => Text -> m a exitMsg = liftIO . throwIO . UserException

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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"