diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,18 @@ 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.2.2 - 2021-09-06 + +### Added + + - `hci lock` subcommands for optional cloud locks, to be used in conjunction with state, but not enforced. + + - `hci` can now run in the effects sandbox inheriting the project's context. (hercules-ci-agent >= 0.8.3) + +### Fixed + + - Interrupt handling + ## 0.2.1 - 2021-06-22 ### Added 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.2.1 +version: 0.2.2 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 @@ -26,6 +26,7 @@ Hercules.CLI.Exception Hercules.CLI.Git Hercules.CLI.JSON + Hercules.CLI.Lock Hercules.CLI.Login Hercules.CLI.Main Hercules.CLI.Nix @@ -61,11 +62,14 @@ , http-client-tls , http-types , katip + , lens + , lens-aeson , lifted-base , monad-control , network-uri , process , protolude + , retry , rio , safe-exceptions , servant @@ -75,10 +79,13 @@ , servant-client-core , temporary , text + , transformers , transformers-base , unix , unliftio + , unliftio-core , unordered-containers + , uuid default-language: Haskell2010 executable hci 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 @@ -23,7 +23,9 @@ import Servant.API.Generic import Servant.Auth.Client (Token) import qualified Servant.Client +import Servant.Client.Core (ClientError, ResponseF) import qualified Servant.Client.Core as Client +import qualified Servant.Client.Core.ClientError as ClientError import Servant.Client.Generic (AsClientT) import Servant.Client.Streaming (ClientM, responseStatusCode, showBaseUrl) import qualified Servant.Client.Streaming @@ -126,3 +128,35 @@ prettyPrintHttpErrors :: IO a -> IO a prettyPrintHttpErrors = handle dieWithHttpError + +-- | 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 +a `inLowRange` (p, q) = a >= p && a < q + +-- In a library, this should support 429 with Retry-After +shouldRetryResponse :: Either ClientError r -> Bool +shouldRetryResponse (Left e) = shouldRetryClientError e +shouldRetryResponse _ = False + +code :: ResponseF a -> Int +code = statusCode . responseStatusCode + +shouldRetryClientError :: ClientError -> Bool +shouldRetryClientError (ClientError.FailureResponse _ resp) | code resp == 501 = False -- 501 Not Implemented +shouldRetryClientError (ClientError.FailureResponse _ resp) | code resp == 505 = False -- 505 HTTP Version Not Supported +shouldRetryClientError (ClientError.FailureResponse _ resp) | code resp == 408 = True -- 408 Request Timeout +shouldRetryClientError (ClientError.FailureResponse _ resp) | code resp `inLowRange` (500, 600) = True +shouldRetryClientError (ClientError.DecodeFailure _ _) = False -- Server programming error or API incompatibility +shouldRetryClientError (ClientError.UnsupportedContentType _ _) = False +shouldRetryClientError (ClientError.InvalidContentTypeHeader _) = False +shouldRetryClientError (ClientError.ConnectionError _) = True +shouldRetryClientError _ = False + +-- | ClientError printer that won't leak sensitive info. +clientErrorSummary :: ClientError -> Text +clientErrorSummary (ClientError.FailureResponse _ resp) = "status " <> show (responseStatusCode resp) +clientErrorSummary ClientError.DecodeFailure {} = "decode failure" +clientErrorSummary ClientError.UnsupportedContentType {} = "unsupported content type" +clientErrorSummary ClientError.InvalidContentTypeHeader {} = "invalid content type header" +clientErrorSummary (ClientError.ConnectionError e) = "connection error: " <> show e diff --git a/src/Hercules/CLI/Common.hs b/src/Hercules/CLI/Common.hs --- a/src/Hercules/CLI/Common.hs +++ b/src/Hercules/CLI/Common.hs @@ -5,7 +5,7 @@ where import Hercules.CLI.Client -import Hercules.CLI.Credentials (determineDomain, readPersonalToken) +import Hercules.CLI.Credentials (determineDomain, readToken) import Hercules.CLI.Exception (exitMsg) import Protolude import RIO (RIO, runRIO) @@ -15,5 +15,5 @@ runAuthenticated m = do clientEnv <- Hercules.CLI.Client.init domain <- determineDomain - token <- readPersonalToken domain + token <- readToken domain runRIO (HerculesClientToken $ Token $ encodeUtf8 token, clientEnv) m diff --git a/src/Hercules/CLI/Credentials.hs b/src/Hercules/CLI/Credentials.hs --- a/src/Hercules/CLI/Credentials.hs +++ b/src/Hercules/CLI/Credentials.hs @@ -4,16 +4,22 @@ -- | Manages the ~/.config/hercules-ci/credentials.json module Hercules.CLI.Credentials where +import Control.Lens ((^?)) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Data.Aeson (FromJSON, ToJSON, eitherDecode) +import qualified Data.Aeson as A +import Data.Aeson.Lens (AsPrimitive (_String), key) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.Map as M +import qualified Data.Text as T import Hercules.CLI.Client (determineDefaultApiBaseUrl) import Hercules.CLI.JSON (writeJsonFile) import Hercules.Error import qualified Network.URI as URI import Protolude import System.Directory (XdgDirectory (XdgConfig), createDirectoryIfMissing, doesFileExist, getXdgDirectory) +import qualified System.Environment import System.FilePath (takeDirectory, ()) data Credentials = Credentials @@ -102,3 +108,23 @@ case M.lookup domain (domains creds) of Nothing -> throwIO NoCredentialException {noCredentialDomain = domain} Just cred -> pure (personalToken cred) + +tryReadEffectToken :: IO (Maybe Text) +tryReadEffectToken = runMaybeT do + inEffect <- MaybeT $ System.Environment.lookupEnv "IN_HERCULES_CI_EFFECT" + guard $ inEffect == "true" + secretsJsonPath <- MaybeT $ System.Environment.lookupEnv "HERCULES_CI_SECRETS_JSON" + liftIO do + bs <- BS.readFile secretsJsonPath + json <- case eitherDecode (BL.fromStrict bs) of + Right x -> pure (x :: A.Value) + Left e -> throwIO $ FatalError $ "HERCULES_CI_SECRETS_JSON, " <> T.pack secretsJsonPath <> " has invalid JSON: " <> T.pack e + case json ^? key "hercules-ci" . key "data" . key "token" . _String of + Just x -> pure x + Nothing -> throwIO $ FatalError $ "HERCULES_CI_SECRETS_JSON, " <> T.pack secretsJsonPath <> " doesn't have key hercules-ci.data.token" + +readToken :: Text -> IO Text +readToken domain = do + tryReadEffectToken >>= \case + Just x -> pure x + Nothing -> readPersonalToken domain 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 @@ -1,10 +1,12 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} module Hercules.CLI.Effect where import Data.Has (Has) import qualified Data.Text as T +import Hercules.API.Id (Id (Id, idUUID)) import qualified Hercules.API.Projects as Projects import qualified Hercules.API.Projects.CreateUserEffectTokenResponse as CreateUserEffectTokenResponse import Hercules.Agent.Sensitive (Sensitive (Sensitive)) @@ -14,14 +16,14 @@ import Hercules.CLI.Git (getAllBranches, getHypotheticalRefs) import Hercules.CLI.Nix (attrByPath, callCiNix, ciNixAttributeCompleter, withNix) import Hercules.CLI.Options (flatCompleter, mkCommand, subparser) -import Hercules.CLI.Project (ProjectPath, getProjectIdAndPath, projectOption) +import Hercules.CLI.Project (ProjectPath, getProjectIdAndPath, projectOption, projectPathText) import Hercules.CLI.Secret (getSecretsFilePath) import Hercules.CNix (Store) import Hercules.CNix.Expr (Match (IsAttrs), Value (rtValue), getAttrBool, getDrvFile, match) import qualified Hercules.CNix.Std.Vector as Std.Vector import Hercules.CNix.Store (Derivation, StorePath, buildPaths, getDerivationInputs, newStorePathWithOutputs) import qualified Hercules.CNix.Store as CNix -import Hercules.Effect (runEffect) +import Hercules.Effect (RunEffectParams (..), runEffect) import Hercules.Error (escalate) import Katip (initLogEnv, runKatipContextT) import Options.Applicative (completer, help, long, metavar, strArgument, strOption) @@ -66,15 +68,25 @@ drvPath <- getDrvFile evalState (rtValue effectAttrs) derivation <- prepareDerivation store drvPath apiBaseURL <- liftIO determineDefaultApiBaseUrl - (projectPath, token) <- wait projectPathAsync - secretsJson <- liftIO $ getSecretsFilePath projectPath + ProjectData {pdProjectPath = projectPath, pdProjectId = projectId, pdToken = token} <- wait projectPathAsync + secretsJson <- liftIO $ traverse getSecretsFilePath projectPath logEnv <- liftIO $ initLogEnv mempty "hci" -- withSystemTempDirectory "hci": -- ERRO[0000] container_linux.go:370: starting container process caused: process_linux.go:459: container init caused: rootfs_linux.go:59: mounting "/run/user/1000/hci6017/secrets" to rootfs at "/run/user/1000/hci6017/runc-state/rootfs/secrets" caused: operation not permitted dataDir <- liftIO $ getAppUserDataDirectory "hercules-ci" createDirectoryIfMissing True dataDir exitCode <- withTempDirectory dataDir "tmp-effect-" \workDir -> do - runKatipContextT logEnv () mempty $ runEffect derivation (Sensitive token) secretsJson apiBaseURL workDir + runKatipContextT logEnv () mempty $ + runEffect + RunEffectParams + { runEffectDerivation = derivation, + runEffectToken = token, + runEffectSecretsConfigPath = secretsJson, + runEffectApiBaseURL = apiBaseURL, + runEffectDir = workDir, + runEffectProjectId = projectId, + runEffectProjectPath = projectPathText <$> projectPath + } throwIO exitCode prepareDerivation :: MonadIO m => Store -> StorePath -> m Derivation @@ -104,7 +116,13 @@ asRefOptions :: Optparse.Parser (Maybe Text) asRefOptions = optional (asRefOption <|> (("refs/heads/" <>) <$> asBranchOption)) -getProjectEffectData :: (Has HerculesClientToken r, Has HerculesClientEnv r) => Maybe ProjectPath -> Bool -> RIO r (ProjectPath, Text) +data ProjectData = ProjectData + { pdProjectPath :: Maybe ProjectPath, + pdProjectId :: Maybe (Id "project"), + pdToken :: Maybe (Sensitive Text) + } + +getProjectEffectData :: (Has HerculesClientToken r, Has HerculesClientEnv r) => Maybe ProjectPath -> Bool -> RIO r ProjectData getProjectEffectData maybeProjectPathParam requireToken = do (projectIdMaybe, path) <- getProjectIdAndPath maybeProjectPathParam if requireToken @@ -114,6 +132,12 @@ 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) - let token = CreateUserEffectTokenResponse.token response - pure (path, token) - else pure (path, "") + let token = Sensitive (CreateUserEffectTokenResponse.token response) + pure ProjectData {pdProjectPath = Just path, pdProjectId = Just $ Id $ idUUID projectId, pdToken = Just token} + else + pure + ProjectData + { pdProjectPath = Nothing, + pdProjectId = Nothing, + pdToken = Nothing + } diff --git a/src/Hercules/CLI/Lock.hs b/src/Hercules/CLI/Lock.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/CLI/Lock.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Hercules.CLI.Lock (commandParser) where + +import Control.Monad.IO.Unlift (UnliftIO (UnliftIO), askUnliftIO) +import Control.Retry (RetryPolicyM, RetryStatus, capDelay, fullJitterBackoff, retrying, rsIterNumber) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Has (Has) +import Data.IORef (IORef) +import qualified Data.UUID +import qualified Data.UUID.V4 as UUID4 +import Hercules.API (Id, NoContent) +import qualified Hercules.API.Accounts.SimpleAccount as SimpleAccount +import Hercules.API.Id (Id (Id), idText) +import qualified Hercules.API.Projects.Project as Project +import qualified Hercules.API.Projects.SimpleJob as SimpleJob +import Hercules.API.State (ProjectStateResourceGroup (acquireLock), StateAPI (deleteLockLease, updateLockLease)) +import qualified Hercules.API.State.StateLockAcquireRequest as StateLockAcquireRequest +import Hercules.API.State.StateLockAcquireResponse (StateLockAcquireResponse (Acquired, Blocked)) +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.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 +import Options.Applicative (help, long, metavar, strArgument, strOption, subparser) +import qualified Options.Applicative as Optparse +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 +import qualified UnliftIO +import UnliftIO.IORef (newIORef, readIORef, writeIORef) + +commandParser, acquireCommandParser, releaseCommandParser, updateCommandParser, runCommandParser :: Optparse.Parser (IO ()) +commandParser = + subparser + ( mkCommand + "acquire" + (Optparse.progDesc "Acquire a lock") + acquireCommandParser + <> mkCommand + "update" + (Optparse.progDesc "Refresh a lock timeout and/or description") + updateCommandParser + <> mkCommand + "release" + (Optparse.progDesc "Release a lock") + releaseCommandParser + <> mkCommand + "run" + (Optparse.progDesc "Run a command holding a lock") + runCommandParser + ) +acquireCommandParser = do + projectMaybe <- optional projectOption + name <- nameOption + json <- jsonOption + description <- fromMaybe "hci lock acquire" <$> optional descriptionOption + exclusive <- exclusiveOption + wait_ <- waitOption + pure do + parent <- getLeaseIdFromEnv + idempotencyKey <- Id <$> UUID4.nextRandom + let request = + StateLockAcquireRequest.StateLockAcquireRequest + { description = description, + exclusive = exclusive, + parent = parent, + idempotencyKey = Just idempotencyKey + } + runAuthenticated do + projectStateClient <- getProjectAndClient projectMaybe + let acquireReq = acquireLock projectStateClient name request + onAcquire s = do + putErrText "hci: lock acquired" + if json + then putLByteString (encodePretty s) + else putText (idText $ StateLockAcquireResponse.leaseId s) + if wait_ + then pollAcquire acquireReq >>= onAcquire + else do + ref <- newIORef Nothing + tryAcquire ref acquireReq >>= \case + Acquired s -> onAcquire s + Blocked s -> do + when json do + putLByteString (encodePretty s) + liftIO exitFailure +releaseCommandParser = do + leaseId <- leaseIdOption + pure do + runAuthenticated do + (_ :: NoContent) <- retryOnFail "lock release" (deleteLockLease stateClient leaseId) + putErrText "hci: lock released" +updateCommandParser = do + leaseId <- leaseIdOption + descriptionUpdate <- optional descriptionOption + json <- jsonOption + pure do + runAuthenticated do + let request = StateLockUpdateRequest.StateLockUpdateRequest {description = descriptionUpdate} + response <- retryOnFail "lock update" (updateLockLease stateClient leaseId request) + when json do + putLByteString (encodePretty response) +runCommandParser = do + projectMaybe <- optional projectOption + name <- nameOption + descriptionMaybe <- optional descriptionOption + exclusive <- exclusiveOption + exe <- strArgument (metavar "COMMAND") + args <- many (strArgument (metavar "ARGS")) + pure do + parent <- getLeaseIdFromEnv + idempotencyKey <- Id <$> UUID4.nextRandom + let request = + StateLockAcquireRequest.StateLockAcquireRequest + { description = description, + exclusive = exclusive, + parent = parent, + idempotencyKey = Just idempotencyKey + } + description = fromMaybe ("hci lock run " <> toS exe) descriptionMaybe + runAuthenticated do + projectStateClient <- getProjectAndClient projectMaybe + lease0 <- pollAcquire (acquireLock projectStateClient name request) + putErrText "hci: lock acquired" + let leaseId = StateLockAcquireResponse.leaseId lease0 + exitCode <- + ( do + env <- liftIO System.Environment.getEnvironment + let procSpec = (System.Process.proc exe args) {System.Process.env = Just env'} + env' = (leaseIdEnvVar, toS (idText leaseId)) : filter (\(k, _) -> k /= leaseIdEnvVar) env + updateRequest = + StateLockUpdateRequest.StateLockUpdateRequest + { -- Not changing anything; just pinging + description = Nothing + } + updateInterval = 3 * 60 * 1000 * 1000 + pinger = do + liftIO $ threadDelay updateInterval + forever do + ( do + (_ :: StateLockAcquireResponse.StateLockAcquiredResponse) <- + retryOnFail "lock pinger" do + updateLockLease stateClient leaseId updateRequest + liftIO $ threadDelay updateInterval + ) + UnliftIO unlift <- askUnliftIO + liftIO do + withAsync + (unlift pinger) + ( \_ -> do + (_, _, _, processHandle) <- System.Process.createProcess procSpec + System.Process.waitForProcess processHandle + ) + ) + `UnliftIO.finally` do + (_ :: NoContent) <- retryOnFail "lock release" (deleteLockLease stateClient leaseId) + 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) -> + (Token -> ClientM StateLockAcquireResponse) -> + RIO r StateLockAcquireResponse +tryAcquire ref acquireLockRequest = do + r <- retryOnFail "lock acquire" acquireLockRequest + case r of + Blocked s -> logBlockedMaybe ref s + Acquired {} -> pass + pure r + +pollAcquire :: + (Has HerculesClientToken r, Has HerculesClientEnv r) => + (Token -> ClientM StateLockAcquireResponse) -> + RIO r StateLockAcquireResponse.StateLockAcquiredResponse +pollAcquire acquireLockRequest = do + ref <- newIORef Nothing + finalResp <- + retrying + waitRetryPolicy + ( \_rs s -> case s of + Blocked {} -> do + putErrText "hci: waiting for lock..." + pure True + Acquired {} -> pure False + ) + (const $ tryAcquire ref acquireLockRequest) + case finalResp of + Blocked {} -> panic "Retrying timed out" -- won't happen; policy is indefinite + Acquired s -> pure s + +logBlockedMaybe :: + MonadIO m => + IORef (Maybe StateLockAcquireResponse.StateLockBlockedResponse) -> + StateLockAcquireResponse.StateLockBlockedResponse -> + m () +logBlockedMaybe ref resp = do + old <- readIORef ref + when (old /= Just resp) do + writeIORef ref (Just resp) + logBlocked resp + +logBlocked :: MonadIO m => StateLockAcquireResponse.StateLockBlockedResponse -> m () +logBlocked s = do + putErrText "hci: lock blocked" + for_ (StateLockAcquireResponse.blockedByLeases s) \lease -> do + putErrText "blocked by lease:" + putErrText $ " description: " <> StateLockLease.description lease + for_ (StateLockLease.user lease) \user -> + putErrText $ " user: " <> SimpleAccount.displayName user <> " (" <> SimpleAccount.name user <> ")" + for_ (StateLockLease.job lease) \job -> do + baseUri <- liftIO getLinksBase + let links = mkLinks baseUri + project = SimpleJob.project job + jobUrl = + Hercules.Frontend.job + links + (Project.siteSlug project) + (Project.ownerSlug project) + (Project.slug project) + (fromIntegral (SimpleJob.index job)) + putErrText $ " job: " <> jobUrl + +getLinksBase :: IO Network.URI.URI +getLinksBase = do + url <- determineDefaultApiBaseUrl + case Network.URI.parseAbsoluteURI (toS url) of + Just x -> pure x + Nothing -> panic "Could not parse API base url" + +-- TODO: bytestring +leaseIdEnvVar :: [Char] +leaseIdEnvVar = "HERCULES_CI_LOCK_LEASE_ID" + +getLeaseIdFromEnv :: IO (Maybe (Id "StateLockLease")) +getLeaseIdFromEnv = do + strMaybe <- System.Environment.lookupEnv leaseIdEnvVar + for strMaybe \str -> case Data.UUID.fromString str of + Just x -> pure (Id x) + Nothing -> do + putErrLn (leaseIdEnvVar <> " is not a valid UUID") + exitFailure + +nameOption :: Optparse.Parser Text +nameOption = strOption $ long "name" <> metavar "NAME" <> help "Name of the lock" + +jsonOption :: Optparse.Parser Bool +jsonOption = Optparse.flag False True (long "json" <> help "Write JSON results on stdout") + +descriptionOption :: Optparse.Parser Text +descriptionOption = strOption $ long "description" <> metavar "TEXT" <> help "Describe the lock activity, for better messages" + +-- NB: exclusive by default; inversion is contained +exclusiveOption :: Optparse.Parser Bool +exclusiveOption = Optparse.flag True False (long "non-exclusive" <> help "Acquire a non-exclusive lock aka read lock") + +-- NB: wait by default; inversion is contained +waitOption :: Optparse.Parser Bool +waitOption = Optparse.flag True False (long "no-wait" <> help "Fail immediately when the lock is already taken") + +leaseIdOption :: Optparse.Parser (Id "StateLockLease") +leaseIdOption = fmap Id $ Optparse.option Optparse.auto $ long "lease-id" <> metavar "UUID" <> help "Lease UUID" 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 @@ -8,6 +8,7 @@ import Hercules.CLI.Client (prettyPrintHttpErrors) import qualified Hercules.CLI.Effect as Effect import qualified Hercules.CLI.Exception as Exception +import qualified Hercules.CLI.Lock as Lock import qualified Hercules.CLI.Login as Login import Hercules.CLI.Options (execParser, helper, mkCommand, subparser) import qualified Hercules.CLI.Secret as Secret @@ -49,10 +50,14 @@ State.commandParser <> mkCommand "effect" - (Optparse.progDesc "Run effects") + (Optparse.progDesc "Run effects locally") Effect.commandParser <> mkCommand "secret" (Optparse.progDesc "Manipulate locally stored secrets") Secret.commandParser + <> mkCommand + "lock" + (Optparse.progDesc "Opt-in locking for use with state") + Lock.commandParser ) 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 @@ -11,6 +11,7 @@ import Hercules.CLI.Options (scanOption) import Hercules.CNix (Store) import Hercules.CNix.Expr as Expr (EvalState, Match (IsAttrs), RawValue, autoCallFunction, evalArgs, evalFile, getAttr, getAttrs, init, isDerivation, match', withEvalState, withStore) +import qualified Hercules.CNix.Util as CNix.Util import Hercules.Error (escalateAs) import Options.Applicative as Optparse import Protolude hiding (evalState) @@ -32,7 +33,9 @@ withNix :: (MonadUnliftIO m) => (Store -> Ptr EvalState -> m b) -> m b withNix f = do - liftIO Expr.init + liftIO do + Expr.init + CNix.Util.installDefaultSigINTHandler UnliftIO unliftIO <- askUnliftIO liftIO $ withStore \store -> withEvalState store (unliftIO . f store) 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 @@ -2,7 +2,9 @@ import qualified Data.Attoparsec.Text as A import Data.Has (Has) +import qualified Data.UUID import Hercules.API (Id) +import Hercules.API.Id (Id (Id)) import Hercules.API.Name (Name (Name)) import Hercules.API.Projects (findProjects) import qualified Hercules.API.Projects as Projects @@ -14,6 +16,7 @@ import Hercules.CLI.Common (exitMsg) import qualified Hercules.CLI.Git as Git import Hercules.CLI.Options (attoparsecReader, packSome) +import Hercules.Error (escalate, escalateAs) import Network.HTTP.Types (Status (Status, statusCode)) import Options.Applicative (bashCompleter, completer, help, long, metavar, option, strOption) import qualified Options.Applicative as Optparse @@ -21,6 +24,7 @@ import RIO (RIO) import Servant.Client.Core (ClientError (FailureResponse), ResponseF (responseStatusCode)) import Servant.Client.Core.Response (ResponseF (Response)) +import UnliftIO.Environment (lookupEnv) import qualified Prelude data ProjectPath = ProjectPath @@ -30,10 +34,11 @@ } instance Prelude.Show ProjectPath where - show = s projectPathSite <> const "/" <> s projectPathOwner <> const "/" <> s projectPathProject - where - s = (toS .) + show = toS . projectPathText +projectPathText :: ProjectPath -> Text +projectPathText = projectPathSite <> const "/" <> projectPathOwner <> const "/" <> projectPathProject + projectOption :: Optparse.Parser ProjectPath projectOption = option projectPathReadM $ @@ -57,16 +62,19 @@ <* A.char '/' <*> packSome (A.satisfy (/= '/')) +parseProjectPathFromText :: Text -> Either [Char] ProjectPath +parseProjectPathFromText = A.parseOnly parseProjectPath + getProjectPath :: (Has HerculesClientToken r, Has HerculesClientEnv r) => Maybe ProjectPath -> RIO r ProjectPath getProjectPath maybeProjectPathParam = case maybeProjectPathParam of - Nothing -> snd <$> findProjectByCurrentRepo + Nothing -> snd <$> findProjectContextually Just projectKey -> pure projectKey getProjectIdAndPath :: (Has HerculesClientToken r, Has HerculesClientEnv r) => Maybe ProjectPath -> RIO r (Maybe (Id Project), ProjectPath) getProjectIdAndPath maybeProjectPathParam = do case maybeProjectPathParam of - Nothing -> findProjectByCurrentRepo + Nothing -> findProjectContextually Just projectKey -> do project <- findProjectByKey projectKey pure (Project.id <$> project, projectKey) @@ -81,6 +89,17 @@ (Just $ Name $ projectPathProject path) ) <&> head + +findProjectContextually :: (Has HerculesClientToken r, Has HerculesClientEnv r) => RIO r (Maybe (Id Project), ProjectPath) +findProjectContextually = do + projectIdMaybe <- lookupEnv "HERCULES_CI_PROJECT_ID" + projectIdPathMaybe <- lookupEnv "HERCULES_CI_PROJECT_PATH" + case (,) <$> projectIdMaybe <*> projectIdPathMaybe of + Nothing -> findProjectByCurrentRepo + Just (id, pathText) -> do + projectPath <- parseProjectPathFromText (toS pathText) & escalateAs (\e -> FatalError $ "Invalid HERCULES_CI_PROJECT_PATH supplied: " <> toS e) + uuid <- Data.UUID.fromString id & maybeToEither (FatalError "Invalid UUID in HERCULES_CI_PROJECT_ID") & escalate + pure (Just (Id uuid), projectPath) findProjectByCurrentRepo :: (Has HerculesClientToken r, Has HerculesClientEnv r) => RIO r (Maybe (Id Project), ProjectPath) findProjectByCurrentRepo = do 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,21 +1,24 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BlockArguments #-} -module Hercules.CLI.State where +module Hercules.CLI.State (commandParser, getProjectAndClient) where import Conduit (ConduitT, mapC, runConduitRes, sinkFile, sourceHandle, stdinC, stdoutC, (.|)) -import Hercules.API (enterApiE) -import qualified Hercules.API.Projects.Project as Project +import Data.Has (Has) +import Hercules.API (ClientAuth, enterApiE) +import Hercules.API.Name (Name (Name)) import Hercules.API.State import Hercules.CLI.Client import Hercules.CLI.Common (runAuthenticated) import Hercules.CLI.Options (mkCommand, subparser) -import Hercules.CLI.Project (findProject, projectOption) +import Hercules.CLI.Project (ProjectPath (projectPathOwner, projectPathProject, projectPathSite), getProjectIdAndPath, projectOption) import Options.Applicative (bashCompleter, completer, help, long, metavar, strOption) import qualified Options.Applicative as Optparse import Protolude hiding (option) import RIO (RIO, runRIO, withBinaryFile) import Servant.API (Headers (Headers), fromSourceIO, toSourceIO) +import Servant.Client.Generic (AsClientT) +import Servant.Client.Internal.HttpClient.Streaming (ClientM) import Servant.Conduit () commandParser, getCommandParser, putCommandParser :: Optparse.Parser (IO ()) @@ -31,13 +34,12 @@ putCommandParser ) getCommandParser = do - project <- projectOption + projectMaybe <- optional projectOption name <- nameOption file <- fileOption pure do runAuthenticated do - projectId <- Project.id <$> findProject project - let projectStateClient = stateClient `enterApiE` \api -> byProjectId api projectId + projectStateClient <- getProjectAndClient projectMaybe -- TODO: version runHerculesClientStream (getStateData projectStateClient name Nothing) \case Left e -> dieWithHttpError e @@ -47,12 +49,12 @@ "-" -> stdoutC _ -> sinkFile file putCommandParser = do - project <- projectOption + projectMaybe <- optional projectOption name <- nameOption file <- fileOption pure do runAuthenticated do - projectId <- Project.id <$> findProject project + projectStateClient <- getProjectAndClient projectMaybe let withStream :: (ConduitT a RawBytes IO () -> RIO r b) -> RIO r b withStream = case file of "-" -> ($ (stdinC .| mapC RawBytes)) @@ -61,7 +63,6 @@ liftIO $ withBinaryFile file ReadMode \h -> runRIO r $ f (sourceHandle h .| mapC RawBytes) withStream \stream -> do - let projectStateClient = stateClient `enterApiE` \api -> byProjectId api projectId _noContent <- runHerculesClient (putStateData projectStateClient name (toSourceIO stream)) pass putErrText $ "hci: State file upload successful for " <> name @@ -71,3 +72,12 @@ fileOption :: Optparse.Parser FilePath fileOption = strOption $ long "file" <> metavar "FILE" <> help "Local path of the state file or - for stdio" <> completer (bashCompleter "file") + +getProjectAndClient :: (Has HerculesClientToken r, Has HerculesClientEnv r) => Maybe ProjectPath -> RIO r (ProjectStateResourceGroup ClientAuth (AsClientT ClientM)) +getProjectAndClient projectMaybe = do + (projectIdMaybe, projectPath) <- getProjectIdAndPath projectMaybe + case projectIdMaybe of + Just projectId -> + pure (stateClient `enterApiE` \api -> byProjectId api projectId) + Nothing -> + pure (stateClient `enterApiE` \api -> byProjectName api (Name $ projectPathSite projectPath) (Name $ projectPathOwner projectPath) (Name $ projectPathProject projectPath))