packages feed

hercules-ci-cli (empty) → 0.1.0

raw patch · 21 files changed

+1383/−0 lines, 21 filesdep +QuickCheckdep +aesondep +aeson-pretty

Dependencies added: QuickCheck, aeson, aeson-pretty, atomic-write, attoparsec, base, bytestring, conduit, containers, data-has, directory, exceptions, filepath, hercules-ci-agent, hercules-ci-api, hercules-ci-api-core, hercules-ci-cli, hercules-ci-cnix-expr, hercules-ci-cnix-store, hercules-ci-optparse-applicative, hostname, hspec, http-client, http-client-tls, http-types, katip, lifted-base, monad-control, network-uri, process, protolude, rio, safe-exceptions, servant, servant-auth-client, servant-client, servant-client-core, servant-conduit, temporary, text, transformers-base, unix, unliftio, unordered-containers

Files

+ CHANGELOG.md view
@@ -0,0 +1,18 @@+# Changelog++All notable changes to this project will be documented in this file.++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).++## [Unreleased]++## 0.1.0++Added++ - First version of the `hci` command+++[Unreleased]: https://github.com/olivierlacan/keep-a-changelog/compare/v1.0.0...HEAD+
+ hci/Main.hs view
@@ -0,0 +1,3 @@+module Main (main) where++import Hercules.CLI.Main (main)
+ hercules-ci-cli.cabal view
@@ -0,0 +1,117 @@+cabal-version: 1.12++name:           hercules-ci-cli+version:        0.1.0+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+author:         Hercules CI contributors+maintainer:     info@hercules-ci.com+copyright:      2018-2020 Hercules CI+license:        Apache-2.0+build-type:     Simple+extra-source-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/hercules-ci/hercules-ci-agent++library+  exposed-modules:+      Hercules.CLI.Client+      Hercules.CLI.Common+      Hercules.CLI.Credentials+      Hercules.CLI.Effect+      Hercules.CLI.Exception+      Hercules.CLI.Git+      Hercules.CLI.JSON+      Hercules.CLI.Login+      Hercules.CLI.Main+      Hercules.CLI.Nix+      Hercules.CLI.Project+      Hercules.CLI.Secret+      Hercules.CLI.State+      Hercules.CLI.Options+  hs-source-dirs:+      src+  default-extensions: DeriveGeneric DeriveTraversable DisambiguateRecordFields FlexibleContexts InstanceSigs LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes TupleSections TypeApplications TypeOperators+  ghc-options: -Wall -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-name-shadowing -fwarn-incomplete-patterns+  build-depends:+      aeson+    , aeson-pretty+    , atomic-write+    , attoparsec+    , base >=4.7 && <5+    , bytestring+    , containers+    , conduit+    , data-has+    , directory+    , exceptions+    , filepath+    , hercules-ci-agent+    , hercules-ci-api+    , hercules-ci-api-core+    , hercules-ci-cnix-expr+    , hercules-ci-cnix-store+    , hercules-ci-optparse-applicative+    , hostname+    , http-client+    , http-client-tls+    , http-types+    , katip+    , lifted-base+    , monad-control+    , network-uri+    , process+    , protolude+    , rio+    , safe-exceptions+    , servant+    , servant-auth-client+    , servant-conduit+    , servant-client+    , servant-client-core+    , temporary+    , text+    , transformers-base+    , unix+    , unliftio+    , unordered-containers+  default-language: Haskell2010++executable hci+  main-is: Main.hs+  other-modules:+  hs-source-dirs:+      hci+  default-extensions: DeriveGeneric DeriveTraversable DisambiguateRecordFields FlexibleContexts InstanceSigs LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes TupleSections TypeApplications TypeOperators+  ghc-options: -Wall -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-name-shadowing -fwarn-incomplete-patterns -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base+    , hercules-ci-cli+  default-language: Haskell2010++test-suite hercules-ci-cli-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Spec+      Hercules.CLI.CredentialsSpec+      Hercules.CLI.JSONSpec+  hs-source-dirs:+      test+  default-extensions: DeriveGeneric DeriveTraversable DisambiguateRecordFields FlexibleContexts InstanceSigs LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes TupleSections TypeApplications TypeOperators+  ghc-options: -Wall -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-name-shadowing -fwarn-incomplete-patterns -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson+    , base+    , bytestring+    , containers+    , hercules-ci-cli+    , hspec+    , protolude+    , QuickCheck+    , unordered-containers+  default-language: Haskell2010
+ src/Hercules/CLI/Client.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -O0 #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Hercules.CLI.Client where++-- TODO https://github.com/haskell-servant/servant/issues/986++import Data.Has (Has, getter)+import qualified Data.Text as T+import Hercules.API (ClientAPI (..), ClientAuth, servantClientApi, useApi)+import Hercules.API.Accounts (AccountsAPI)+import Hercules.API.Projects (ProjectsAPI)+import Hercules.API.Repos (ReposAPI)+import Hercules.API.State (ContentDisposition, ContentLength, RawBytes, StateAPI)+import Hercules.Error+import qualified Network.HTTP.Client.TLS+import Network.HTTP.Types.Status+import Protolude+import RIO (RIO)+import Servant.API+import Servant.API.Generic+import Servant.Auth.Client (Token)+import qualified Servant.Client+import qualified Servant.Client.Core as Client+import Servant.Client.Generic (AsClientT)+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++client :: ClientAPI ClientAuth (AsClientT ClientM)+client = fromServant $ Servant.Client.Streaming.client (servantClientApi @ClientAuth)++accountsClient :: AccountsAPI ClientAuth (AsClientT ClientM)+accountsClient = useApi clientAccounts client++stateClient :: StateAPI ClientAuth (AsClientT ClientM)+stateClient = useApi clientState client++projectsClient :: ProjectsAPI ClientAuth (AsClientT ClientM)+projectsClient = useApi clientProjects client++reposClient :: ReposAPI ClientAuth (AsClientT ClientM)+reposClient = useApi clientRepos client++-- Duplicated from agent... create common lib?+determineDefaultApiBaseUrl :: IO Text+determineDefaultApiBaseUrl = do+  maybeEnv <- System.Environment.lookupEnv "HERCULES_CI_API_BASE_URL"+  pure $ maybe defaultApiBaseUrl toS maybeEnv++defaultApiBaseUrl :: Text+defaultApiBaseUrl = "https://hercules-ci.com"++newtype HerculesClientEnv = HerculesClientEnv Servant.Client.ClientEnv++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+  runHerculesClientEither' $ f token++runHerculesClientStream ::+  (Has HerculesClientToken r, Has HerculesClientEnv r) =>+  (Token -> Servant.Client.Streaming.ClientM a) ->+  (Either Servant.Client.Streaming.ClientError a -> IO b) ->+  RIO r b+runHerculesClientStream f g = do+  HerculesClientToken token <- asks getter+  HerculesClientEnv clientEnv <- asks getter+  liftIO $ 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++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)++init :: IO HerculesClientEnv+init = do+  manager <- Network.HTTP.Client.TLS.newTlsManager+  baseUrlText <- determineDefaultApiBaseUrl+  baseUrl <- Servant.Client.parseBaseUrl $ toS baseUrlText+  let clientEnv :: Servant.Client.ClientEnv+      clientEnv = Servant.Client.mkClientEnv manager baseUrl+  pure $ HerculesClientEnv clientEnv++dieWithHttpError :: Client.ClientError -> IO a+dieWithHttpError (Client.FailureResponse req resp) = do+  let status = responseStatusCode resp+      (base, path) = Client.requestPath req+  putErrText $+    "hci: Request failed; "+      <> show (statusCode status)+      <> " "+      <> decodeUtf8With lenientDecode (statusMessage status)+      <> " on: "+      <> toS (showBaseUrl base)+      <> "/"+      <> T.dropWhile (== '/') (decodeUtf8With lenientDecode path)+  liftIO exitFailure+dieWithHttpError e = do+  putErrText $ "hci: Request failed: " <> toS (displayException e)+  liftIO exitFailure++prettyPrintHttpErrors :: IO a -> IO a+prettyPrintHttpErrors = handle dieWithHttpError
+ src/Hercules/CLI/Common.hs view
@@ -0,0 +1,19 @@+module Hercules.CLI.Common+  ( runAuthenticated,+    exitMsg,+  )+where++import Hercules.CLI.Client+import Hercules.CLI.Credentials (determineDomain, readPersonalToken)+import Hercules.CLI.Exception (exitMsg)+import Protolude+import RIO (RIO, runRIO)+import Servant.Auth.Client (Token (Token))++runAuthenticated :: RIO (HerculesClientToken, HerculesClientEnv) b -> IO b+runAuthenticated m = do+  clientEnv <- Hercules.CLI.Client.init+  domain <- determineDomain+  token <- readPersonalToken domain+  runRIO (HerculesClientToken $ Token $ encodeUtf8 token, clientEnv) m
+ src/Hercules/CLI/Credentials.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveAnyClass #-}++-- | Manages the ~/.config/hercules-ci/credentials.json+module Hercules.CLI.Credentials where++import Data.Aeson (FromJSON, ToJSON, eitherDecode)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as M+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 System.FilePath (takeDirectory, (</>))++data Credentials = Credentials+  { domains :: Map Text DomainCredentials+  }+  deriving (Eq, Generic, FromJSON, ToJSON)++data DomainCredentials = DomainCredentials+  { personalToken :: Text+  }+  deriving (Eq, Generic, FromJSON, ToJSON)++data CredentialsParsingException = CredentialsParsingException+  { filePath :: FilePath,+    message :: Text+  }+  deriving (Show, Eq)++instance Exception CredentialsParsingException where+  displayException e = "Could not parse credentials file " <> filePath e <> ": " <> toS (message e)++data NoCredentialException = NoCredentialException+  { noCredentialDomain :: Text+  }+  deriving (Show, Eq)++instance Exception NoCredentialException where+  displayException e = "Could not find credentials for domain " <> toS (noCredentialDomain e) <> ". Please run hci login."++data ApiBaseUrlParsingException = ApiBaseUrlParsingException+  { apiBaseUrlParsingMessage :: Text+  }+  deriving (Show, Eq)++instance Exception ApiBaseUrlParsingException where+  displayException e = "Could not parse the api domain: " <> toS (apiBaseUrlParsingMessage e) <> ". Please correct the HERCULES_CI_API_BASE_URL environment variable."++getCredentialsFilePath :: IO FilePath+getCredentialsFilePath = do+  dir <- getXdgDirectory XdgConfig "hercules-ci"+  pure $ dir </> "credentials.json"++readCredentials :: IO Credentials+readCredentials = do+  filePath_ <- getCredentialsFilePath+  doesFileExist filePath_ >>= \case+    False -> pure (Credentials mempty)+    True -> do+      bs <- BS.readFile filePath_+      escalate $ parseCredentials filePath_ bs++parseCredentials :: FilePath -> ByteString -> Either CredentialsParsingException Credentials+parseCredentials filePath_ bs =+  case eitherDecode (BL.fromStrict bs) of+    Right a -> Right a+    Left e -> Left (CredentialsParsingException {filePath = filePath_, message = toS e})++writeCredentials :: Credentials -> IO ()+writeCredentials credentials = do+  filePath_ <- getCredentialsFilePath+  createDirectoryIfMissing True (takeDirectory filePath_)+  writeJsonFile filePath_ credentials++urlDomain :: Text -> Either Text Text+urlDomain urlText = do+  uri <- maybeToEither "could not parse HERCULES_CI_API_BASE_URL" $ URI.parseAbsoluteURI (toS urlText)+  authority <- maybeToEither "HERCULES_CI_API_BASE_URL has no domain/authority part" $ URI.uriAuthority uri+  let name = URI.uriRegName authority+  maybeToEither "HERCULES_CI_API_BASE_URL domain name must not be empty" $ guard (name /= "")+  pure (toS name)++determineDomain :: IO Text+determineDomain = do+  baseUrl <- determineDefaultApiBaseUrl+  escalateAs ApiBaseUrlParsingException (urlDomain baseUrl)++writePersonalToken :: Text -> Text -> IO ()+writePersonalToken domain token = do+  creds <- readCredentials+  let creds' = creds {domains = domains creds & M.insert domain (DomainCredentials token)}+  writeCredentials creds'++readPersonalToken :: Text -> IO Text+readPersonalToken domain = do+  creds <- readCredentials+  case M.lookup domain (domains creds) of+    Nothing -> throwIO NoCredentialException {noCredentialDomain = domain}+    Just cred -> pure (personalToken cred)
+ src/Hercules/CLI/Effect.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}++module Hercules.CLI.Effect where++import Data.Has (Has)+import qualified Data.Text as T+import Foreign (ForeignPtr)+import qualified Hercules.API.Projects as Projects+import qualified Hercules.API.Projects.CreateUserEffectTokenResponse as CreateUserEffectTokenResponse+import Hercules.Agent.Sensitive (Sensitive (Sensitive))+import Hercules.CLI.Client (HerculesClientEnv, HerculesClientToken, determineDefaultApiBaseUrl, projectsClient, runHerculesClient)+import Hercules.CLI.Common (runAuthenticated)+import Hercules.CLI.Exception (exitMsg)+import Hercules.CLI.Git (getAllBranches, getHypotheticalRefs)+import Hercules.CLI.Nix (attrByPath, callCiNix, ciNixAttributeCompleter, withNix)+import Hercules.CLI.Options (flatCompleter, mkCommand)+import Hercules.CLI.Project (ProjectPath, getProjectIdAndPath, projectOption)+import Hercules.CLI.Secret (getSecretsFilePath)+import Hercules.CNix (Store)+import Hercules.CNix.Expr (Match (IsAttrs), Value (rtValue), getAttrBool, getDrvFile, match)+import Hercules.CNix.Store (buildPaths, getDerivationInputs)+import qualified Hercules.CNix.Store as CNix+import Hercules.CNix.Store.Context (Derivation)+import Hercules.Effect (runEffect)+import Hercules.Error (escalate)+import Katip (initLogEnv, runKatipContextT)+import Options.Applicative (completer, help, long, metavar, strArgument, strOption)+import qualified Options.Applicative as Optparse+import Protolude hiding (evalState, wait, withAsync)+import RIO (RIO)+import UnliftIO.Async (wait, withAsync)+import UnliftIO.Directory (createDirectoryIfMissing, getAppUserDataDirectory)+import UnliftIO.Temporary (withTempDirectory)++commandParser, runParser :: Optparse.Parser (IO ())+commandParser =+  Optparse.subparser+    ( mkCommand+        "run"+        (Optparse.progDesc "Run an effect")+        runParser+    )+runParser = do+  attr <- ciAttributeArgument+  projectOptionMaybe <- optional projectOption+  refMaybe <- asRefOptions+  requireToken <- Optparse.flag True False (long "no-token" <> help "Don't get an API token. Disallows access to state files, but can run in untrusted environment or unconfigured repo.")+  pure $ runAuthenticated do+    withAsync (getProjectEffectData projectOptionMaybe requireToken) \projectPathAsync -> do+      withNix \store evalState -> do+        (nixFile, rootValue) <- liftIO $ callCiNix evalState refMaybe+        let attrPath = T.split (== '.') attr+        valMaybe <- liftIO $ attrByPath evalState rootValue (map encodeUtf8 attrPath)+        attrValue <- case valMaybe of+          Nothing -> do+            exitMsg $ "Could not find an attribute at path " <> show attrPath <> " in " <> toS nixFile+          Just v -> liftIO (match evalState v) >>= escalate+        effectAttrs <- case attrValue of+          IsAttrs attrs -> pure attrs+          _ -> do+            exitMsg $ "Attribute is not an Effect at path " <> show attrPath <> " in " <> toS nixFile++        isEffect <- liftIO $ getAttrBool evalState effectAttrs "isEffect" >>= escalate+        when (isEffect /= Just True) do+          exitMsg $ "Attribute is not an Effect at path " <> show attrPath <> " in " <> toS nixFile+        drvPath <- getDrvFile evalState (rtValue effectAttrs)+        derivation <- prepareDerivation store drvPath+        apiBaseURL <- liftIO determineDefaultApiBaseUrl+        (projectPath, token) <- wait projectPathAsync+        secretsJson <- liftIO $ 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+        throwIO exitCode++prepareDerivation :: MonadIO m => Store -> ByteString -> m (ForeignPtr Derivation)+prepareDerivation store drvPath = do+  derivation <- liftIO $ CNix.getDerivation store drvPath+  inputs <- liftIO $ getDerivationInputs derivation+  let paths = [input <> "!" <> output | (input, outputs) <- inputs, output <- outputs]+  liftIO $ buildPaths store paths+  pure derivation++ciAttributeArgument :: Optparse.Parser Text+ciAttributeArgument =+  strArgument $+    metavar "CI_NIX_ATTRIBUTE"+      <> help "Attribute to run"+      <> completer ciNixAttributeCompleter++asBranchOption :: Optparse.Parser Text+asBranchOption = strOption $ long "as-branch" <> metavar "BRANCH" <> help "Pretend we're on another git branch" <> completer (flatCompleter getAllBranches)++asRefOption :: Optparse.Parser Text+asRefOption = strOption $ long "as-ref" <> metavar "REF" <> help "Pretend we're on another git ref" <> completer (flatCompleter getHypotheticalRefs)++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)+getProjectEffectData maybeProjectPathParam requireToken = do+  (projectIdMaybe, path) <- getProjectIdAndPath maybeProjectPathParam+  if requireToken+    then do+      projectId <- case projectIdMaybe of+        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)+      let token = CreateUserEffectTokenResponse.token response+      pure (path, token)+    else pure (path, "")
+ src/Hercules/CLI/Exception.hs view
@@ -0,0 +1,28 @@+module Hercules.CLI.Exception where++import qualified Control.Exception.Safe+import Protolude hiding (handle, show)+import System.IO (hIsTerminalDevice)+import Text.Show++data UserException = UserException Text++instance Exception UserException where+  displayException = show++instance Show UserException where+  show (UserException msg) = "error: " <> toS msg++handleUserException :: IO a -> IO a+handleUserException =+  Control.Exception.Safe.handle+    ( \(UserException msg) -> do+        stderrIsTerminal <- hIsTerminalDevice stderr+        if stderrIsTerminal+          then putErrText $ "hci: \ESC[31;1merror:\ESC[m " <> msg+          else putErrText $ "hci: error: " <> msg+        exitFailure+    )++exitMsg :: MonadIO m => Text -> m a+exitMsg = liftIO . throwIO . UserException
+ src/Hercules/CLI/Git.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE BlockArguments #-}++module Hercules.CLI.Git where++import Data.List (dropWhileEnd)+import qualified Data.Text as T+import Hercules.CLI.Exception (exitMsg)+import Protolude+import System.Directory (doesDirectoryExist)+import System.Process (readProcess)++readProcessString :: FilePath -> [[Char]] -> [Char] -> IO [Char]+readProcessString exe args input = dropWhileEnd (== '\n') <$> readProcess exe args input++readProcessItem :: FilePath -> [[Char]] -> [Char] -> IO Text+readProcessItem exe args input = toS <$> readProcessString exe args input++getGitRoot :: IO FilePath+getGitRoot = do+  p <- readProcessString "git" ["rev-parse", "--show-toplevel"] mempty+  unlessM (doesDirectoryExist p) $ panic $ "git root `" <> toS p <> "` is not a directory?"+  pure p++getRemotes :: IO [Text]+getRemotes = readProcess "git" ["remote"] mempty <&> toS <&> lines <&> filter (/= "")++getRef :: IO Text+getRef = do+  readProcessItem "git" ["rev-parse", "--symbolic-full-name", "HEAD"] mempty++getRev :: IO Text+getRev = do+  readProcessItem "git" ["rev-parse", "HEAD"] mempty++-- | rev (sha) and ref+getRevsAndRefs :: IO [(Text, Text)]+getRevsAndRefs =+  -- restrict to heads and tags, because other ones aren't relevant on CI, probably+  readProcess "git" ["show-ref"] mempty <&> \x ->+    x & toS+      & T.lines+      & map \ln ->+        ln+          & T.break isSpace+          & fmap (T.dropWhile isSpace)++getRefs :: IO [Text]+getRefs = getRevsAndRefs <&> map snd++getHypotheticalRefs :: IO [Text]+getHypotheticalRefs = do+  refs <- getRefs+  pure $ sort $ ordNub (refs <> map ("refs/heads/" <>) (allBranches refs))++allBranches :: [Text] -> [Text]+allBranches = concatMap filterRef+  where+    filterRef ref =+      toList (T.stripPrefix "refs/heads/" ref)+        <|> T.dropWhile (== '/') . T.dropWhile (/= '/') <$> toList (T.stripPrefix "refs/remotes/" ref)++getAllBranches :: IO [Text]+getAllBranches = getRefs <&> allBranches++getUpstreamURL :: IO Text+getUpstreamURL = do+  remotes <- getRemotes+  case remotes of+    [x] -> getRemoteURL x+    _ -> do+      (getBranchUpstream >>= getRemoteURL) `onException` do+        putErrText "hci: could not determine git upstream repository url"++getBranchUpstream :: IO Text+getBranchUpstream = do+  upstreamRef <- readProcessString "git" ["rev-parse", "--symbolic-full-name", "@{u}"] mempty+  let refsRemotes = "refs/remotes/"+  if refsRemotes `isPrefixOf` upstreamRef+    then pure $ toS $ takeWhile (/= '/') $ drop (length refsRemotes) upstreamRef+    else do+      exitMsg "upstream branch is not remote"++getRemoteURL :: Text -> IO Text+getRemoteURL remoteName =+  readProcessItem "git" ["remote", "get-url", toS remoteName] mempty
+ src/Hercules/CLI/JSON.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE OverloadedStrings #-}++module Hercules.CLI.JSON where++import Data.Aeson+import Data.Aeson.Encode.Pretty (Indent (Spaces), confIndent, confTrailingNewline, defConfig, encodePretty')+import qualified Data.Aeson.Encode.Pretty+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Strict as HM+import qualified Data.List.NonEmpty as NEL+import qualified Data.Text as T+import qualified Options.Applicative as Optparse+import Protolude+import System.AtomicWrite.Writer.ByteString (atomicWriteFile)++mergePaths :: [([Text], Value)] -> Either Text Value+mergePaths = mergeLeafPaths [] . toLeafPaths++mergeLeafPaths :: [Text] -> [([Text], Value)] -> Either Text Value+mergeLeafPaths _ [([], v)] = Right v+mergeLeafPaths context items =+  case for items (\(k, v) -> (,v) <$> NEL.nonEmpty k) of+    Nothing -> Left $ "Conflicting values for " <> showPath context+    Just nonRootItems ->+      nonRootItems+        & NEL.groupAllWith (NEL.head . fst)+        & traverse+          ( \(groupItem@(child :| _, _) :| groupItems) ->+              (child .=)+                <$> mergeLeafPaths (context ++ [child]) (map (first NEL.tail) (groupItem : groupItems))+          )+        <&> object++showPath :: [Text] -> Text+showPath [] = "the root"+showPath x = T.intercalate "." x++toLeafPaths :: [([Text], Value)] -> [([Text], Value)]+toLeafPaths = concatMap \(path, item) ->+  case item of+    Object fields ->+      fields & HM.toList & concatMap \(subpath, subitem) ->+        toLeafPaths [(path ++ [subpath], subitem)]+    _ -> [(path, item)]++options :: Optparse.Parser (IO Value)+options = do+  strings <-+    many+      ( Optparse.biOption+          Optparse.str+          Optparse.str+          ( Optparse.long "string"+              <> Optparse.help "Define a string at dot-separated PATH in the secret data"+              <> Optparse.metavar "PATH"+              <> Optparse.metavar2 "STRING"+          )+      )+  jsons <-+    many+      ( Optparse.biOption+          Optparse.str+          Optparse.str+          ( Optparse.long "json"+              <> Optparse.help "Define a JSON value at dot-separated PATH in the secret data"+              <> Optparse.metavar "PATH"+              <> Optparse.metavar2 "JSON"+          )+      )+  stringFiles <-+    many+      ( Optparse.biOption+          Optparse.str+          Optparse.str+          ( Optparse.long "string-file"+              <> Optparse.help "Define a string at dot-separated PATH in the secret data, by reading FILE"+              <> Optparse.metavar "PATH"+              <> Optparse.metavar2 "FILE"+              <> Optparse.completer2 (Optparse.bashCompleter "file")+          )+      )+  jsonFiles <-+    many+      ( Optparse.biOption+          Optparse.str+          Optparse.str+          ( Optparse.long "json-file"+              <> Optparse.help "Define a JSON value at dot-separated PATH in the secret data, by reading FILE"+              <> Optparse.metavar "PATH"+              <> Optparse.metavar2 "FILE"+              <> Optparse.completer2 (Optparse.bashCompleter "file")+          )+      )+  pure do+    fileStrings <- for stringFiles readFileWithKey+    fileJsons <- for jsonFiles readJsonFileWithKey+    validJsons <-+      for+        jsons+        ( \(key, value) ->+            case eitherDecode $ BL.fromStrict $ encodeUtf8 value of+              Left e -> throwIO $ FatalError $ "Value for key " <> key <> " is not valid JSON: " <> show e+              Right r -> pure (key, r :: Value)+        )+    let items =+          (fmap String <$> strings) <> (fmap String <$> fileStrings) <> validJsons <> fileJsons+            & map (first split)+        split "." = []+        split "" = []+        split p = T.split (== '.') p+    when (items & any \(path, _) -> path & any (T.any (== '\"'))) do+      throwIO $ FatalError "Quotes in field names are not allowed, so proper quotation can be implemented in the future. Write the field name in the value of --json or --json-file instead."+    case mergePaths items of+      Left e -> throwIO $ FatalError $ show e+      Right r -> pure r++readFileWithKey :: (Text, FilePath) -> IO (Text, Text)+readFileWithKey (key, file) = do+  bs <- BS.readFile file+  case decodeUtf8' bs of+    Left _e -> throwIO $ FatalError $ "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 (key, file) = do+  bs <- BS.readFile file+  case eitherDecode (BL.fromStrict bs) of+    Left e -> throwIO $ FatalError $ "File " <> show file <> " for key " <> key <> " is not valid JSON: " <> show e+    Right s -> pure (key, s)++readJsonFile :: FromJSON b => FilePath -> IO b+readJsonFile file = do+  bs <- BS.readFile file+  case eitherDecode (BL.fromStrict bs) of+    Left e -> throwIO $ FatalError $ "File " <> show file <> " is not valid JSON: " <> show e+    Right s -> pure s++writeJsonFile :: ToJSON a => FilePath -> a -> IO ()+writeJsonFile filePath v =+  atomicWriteFile filePath $ BL.toStrict $ encodePretty' prettyConf v++prettyConf :: Data.Aeson.Encode.Pretty.Config+prettyConf =+  defConfig+    { -- Indentation convention for Nix expressions is also 2+      confIndent = Spaces 2,+      -- UNIX convention+      confTrailingNewline = True+    }
+ src/Hercules/CLI/Login.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NumericUnderscores #-}++module Hercules.CLI.Login+  ( commandParser,+  )+where++import qualified Hercules.API.Accounts as Accounts+import Hercules.API.Accounts.CLIAuthorizationRequestCreate (CLIAuthorizationRequestCreate (CLIAuthorizationRequestCreate))+import qualified Hercules.API.Accounts.CLIAuthorizationRequestCreate as CLIAuthorizationRequestCreate+import qualified Hercules.API.Accounts.CLIAuthorizationRequestCreateResponse as CLIAuthorizationRequestCreateResponse+import qualified Hercules.API.Accounts.CLIAuthorizationRequestStatus as CLIAuthorizationRequestStatus+import Hercules.CLI.Client+import qualified Hercules.CLI.Credentials as Credentials+import Network.HostName (getHostName)+import qualified Options.Applicative as Optparse+import Protolude+import RIO (runRIO)+import System.Posix.User++commandParser :: Optparse.Parser (IO ())+commandParser = pure do+  hostname <- liftIO getHostName+  username <- getLoginName+  clientEnv <- Hercules.CLI.Client.init+  runRIO ((), clientEnv) do+    r <- runHerculesClient' do+      Accounts.postCLIAuthorizationRequest+        accountsClient+        CLIAuthorizationRequestCreate+          { description = toS username <> "@" <> toS hostname+          }+    putErrText "Please confirm your login at "+    putErrText $ "  " <> CLIAuthorizationRequestCreateResponse.browserURL r+    putErrText "Waiting for confirmation..."+    let tmpTok = CLIAuthorizationRequestCreateResponse.temporaryCLIToken r+        -- TODO do something pretty with 404+        pollLoop = do+          s <- runHerculesClient' do+            Accounts.getCLIAuthorizationRequestStatus accountsClient tmpTok+          case CLIAuthorizationRequestStatus.status s of+            CLIAuthorizationRequestStatus.Pending {} -> do+              liftIO (threadDelay 1_000_000)+              pollLoop+            CLIAuthorizationRequestStatus.Granted g -> pure g+    granted <- pollLoop+    domain <- liftIO Credentials.determineDomain+    liftIO (Credentials.writePersonalToken domain (CLIAuthorizationRequestStatus.token granted))+    for_ (CLIAuthorizationRequestStatus.userIdentities granted) \userIdentity ->+      putErrText $ "hci is configured to perform operations for " <> userIdentity <> " on " <> domain
+ src/Hercules/CLI/Main.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE BlockArguments #-}++module Hercules.CLI.Main+  ( main,+  )+where++import Hercules.CLI.Client (prettyPrintHttpErrors)+import qualified Hercules.CLI.Effect as Effect+import qualified Hercules.CLI.Exception as Exception+import qualified Hercules.CLI.Login as Login+import Hercules.CLI.Options (mkCommand)+import qualified Hercules.CLI.Secret as Secret+import qualified Hercules.CLI.State as State+import qualified Options.Applicative as Optparse+import Protolude++main :: IO ()+main =+  prettyPrintErrors $+    Exception.handleUserException $+      prettyPrintHttpErrors $ do+        join $ Optparse.execParser opts++prettyPrintErrors :: IO a -> IO a+prettyPrintErrors = handle \e ->+  case fromException e :: Maybe ExitCode of+    Just _ -> throwIO e+    Nothing -> do+      putErrLn $ "hci: " <> displayException e+      exitFailure++opts :: Optparse.ParserInfo (IO ())+opts =+  Optparse.info+    (commands <**> Optparse.helper)+    (Optparse.fullDesc <> Optparse.header "Command line interface to Hercules CI")++commands :: Optparse.Parser (IO ())+commands =+  Optparse.subparser+    ( mkCommand+        "login"+        (Optparse.progDesc "Configure token for authentication to hercules-ci.com")+        Login.commandParser+        <> mkCommand+          "state"+          (Optparse.progDesc "Perform operations on state files")+          State.commandParser+        <> mkCommand+          "effect"+          (Optparse.progDesc "Run effects")+          Effect.commandParser+        <> mkCommand+          "secret"+          (Optparse.progDesc "Manipulate locally stored secrets")+          Secret.commandParser+    )
+ src/Hercules/CLI/Nix.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE BlockArguments #-}++module Hercules.CLI.Nix where++import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.Text as T+import Hercules.Agent.NixFile (findNixFile)+import Hercules.CLI.Git (getGitRoot, getRef, getRev)+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 Hercules.Error (escalateAs)+import Options.Applicative as Optparse+import Protolude hiding (evalState)+import UnliftIO (MonadUnliftIO, UnliftIO (UnliftIO), askUnliftIO)++callCiNix :: Ptr EvalState -> Maybe Text -> IO (FilePath, RawValue)+callCiNix evalState passedRef = do+  gitRoot <- getGitRoot+  gitRev <- getRev+  gitRef <- getRef+  nixFile <- findNixFile gitRoot >>= escalateAs FatalError+  let ref = fromMaybe gitRef passedRef+  args <- evalArgs evalState ["--arg", "src", "{ ref = ''" <> encodeUtf8 ref <> "''; rev = ''" <> encodeUtf8 gitRev <> "''; outPath = ''" <> encodeUtf8 (toS gitRoot) <> "''; }"]+  rootValueOrFunction <- evalFile evalState nixFile+  (nixFile,) <$> autoCallFunction evalState rootValueOrFunction args++refBranchToRef :: Maybe Text -> Maybe Text -> Maybe Text+refBranchToRef ref branch = ref <|> (("refs/heads/" <>) <$> branch)++withNix :: (MonadUnliftIO m) => (Store -> Ptr EvalState -> m b) -> m b+withNix f = do+  liftIO Expr.init+  UnliftIO unliftIO <- askUnliftIO+  liftIO $ withStore \store -> withEvalState store (unliftIO . f store)++ciNixAttributeCompleter :: Optparse.Completer+ciNixAttributeCompleter = mkTextCompleter \partial -> do+  withNix \_store evalState -> do+    ref <- do+      ref <- scanOption "--as-ref"+      branch <- scanOption "--as-branch"+      pure $ refBranchToRef ref branch+    (_, rootValue) <- callCiNix evalState ref+    let partialComponents = T.split (== '.') partial+        prefix = L.init partialComponents+        partialComponent = lastMay partialComponents & fromMaybe ""+        prefixStr = T.intercalate "." prefix+        addPrefix x = T.intercalate "." (prefix <> [x])+    attrByPath evalState rootValue (encodeUtf8 <$> prefix) >>= \case+      Nothing -> pure []+      Just focusValue -> do+        match' evalState focusValue >>= \case+          IsAttrs attrset -> do+            attrs <- getAttrs attrset+            isDeriv <- isDerivation evalState focusValue+            if isDeriv+              then pure [(mempty {Optparse.cioFiles = False}, prefixStr)]+              else+                let matches =+                      attrs+                        & M.keys+                        & map decodeUtf8+                        & filter (/= "recurseForDerivations")+                        & filter (T.isPrefixOf partialComponent)+                 in case matches of+                      [singleMatch] -> do+                        ma <- getAttr evalState attrset (encodeUtf8 singleMatch)+                        matchIsDeriv <-+                          ma & traverse (isDerivation evalState)+                            <&> fromMaybe False+                        if matchIsDeriv+                          then+                            pure $+                              matches+                                & map (\match -> (mempty {Optparse.cioAddSpace = True, Optparse.cioFiles = False}, addPrefix match))+                          else+                            pure $+                              matches+                                & map (\match -> (mempty {Optparse.cioAddSpace = False, Optparse.cioFiles = False}, addPrefix match <> "."))+                      _ ->+                        pure $+                          matches+                            & map (\match -> (mempty {Optparse.cioAddSpace = False, Optparse.cioFiles = False}, addPrefix match))+          _ -> pure []++attrByPath :: Ptr EvalState -> RawValue -> [ByteString] -> IO (Maybe RawValue)+attrByPath _ v [] = pure (Just v)+attrByPath evalState v (a : as) = do+  match' evalState v >>= \case+    IsAttrs attrs ->+      getAttr evalState attrs a+        >>= traverse (\attrValue -> attrByPath evalState attrValue as)+        & fmap join+    _ -> pure Nothing++mkTextCompleter :: (Text -> IO [(Optparse.CompletionItemOptions, Text)]) -> Completer+mkTextCompleter f = Optparse.mkCompleterWithOptions (fmap (fmap (uncurry CompletionItem . fmap toS)) . f . toS)
+ src/Hercules/CLI/Options.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE BlockArguments #-}++module Hercules.CLI.Options where++import qualified Data.Attoparsec.Text as A+import qualified Data.Text as T+import Options.Applicative+import Protolude++mkCommand ::+  [Char] ->+  InfoMod a ->+  Parser a ->+  Mod CommandFields a+mkCommand name infos cmdParser =+  command name (info (helper <*> cmdParser) infos)++packSome :: A.Parser Char -> A.Parser Text+packSome = fmap T.pack . some++attoparsecReader :: A.Parser a -> ReadM a+attoparsecReader p = eitherReader (A.parseOnly p . T.pack)++scanArguments :: Text -> [Text] -> [Text]+scanArguments opt (opt' : val : opts) | opt == opt' = val : scanArguments opt opts+scanArguments opt (_ : opts) = scanArguments opt opts+scanArguments _ _ = []++getCompletionWords :: IO [Text]+getCompletionWords = scanArguments "--bash-completion-word" . fmap toS <$> getArgs++scanOption :: Text -> IO (Maybe Text)+scanOption opt = do+  lastMay . scanArguments opt <$> getCompletionWords++flatCompleter :: IO [Text] -> Completer+flatCompleter generate = mkCompleter \prefix -> do+  items <- generate+  pure $+    items+      & filter (T.isPrefixOf (toS prefix))+      & map toS
+ src/Hercules/CLI/Project.hs view
@@ -0,0 +1,118 @@+module Hercules.CLI.Project where++import qualified Data.Attoparsec.Text as A+import Data.Has (Has)+import Hercules.API (Id)+import Hercules.API.Name (Name (Name))+import Hercules.API.Projects (findProjects)+import qualified Hercules.API.Projects as Projects+import Hercules.API.Projects.Project (Project)+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.Common (exitMsg)+import qualified Hercules.CLI.Git as Git+import Hercules.CLI.Options (attoparsecReader, packSome)+import Network.HTTP.Types (Status (Status, statusCode))+import Options.Applicative (bashCompleter, completer, help, long, metavar, option, strOption)+import qualified Options.Applicative as Optparse+import Protolude hiding (option)+import RIO (RIO)+import Servant.Client.Core (ClientError (FailureResponse), ResponseF (responseStatusCode))+import Servant.Client.Core.Response (ResponseF (Response))+import qualified Prelude++data ProjectPath = ProjectPath+  { projectPathSite :: Text,+    projectPathOwner :: Text,+    projectPathProject :: Text+  }++instance Prelude.Show ProjectPath where+  show = s projectPathSite <> const "/" <> s projectPathOwner <> const "/" <> s projectPathProject+    where+      s = (toS .)++projectOption :: Optparse.Parser ProjectPath+projectOption =+  option projectPathReadM $+    long "project" <> metavar "PROJECT" <> help "Project path, e.g. github/my-org/my-project"++nameOption :: Optparse.Parser Text+nameOption = strOption $ long "name" <> metavar "NAME" <> help "Name of the state file"++fileOption :: Optparse.Parser FilePath+fileOption = strOption $ long "file" <> metavar "FILE" <> help "Local path of the state file or - for stdio" <> completer (bashCompleter "file")++projectPathReadM :: Optparse.ReadM ProjectPath+projectPathReadM = attoparsecReader parseProjectPath++parseProjectPath :: A.Parser ProjectPath+parseProjectPath =+  pure ProjectPath+    <*> packSome (A.satisfy (/= '/'))+    <* A.char '/'+    <*> packSome (A.satisfy (/= '/'))+    <* A.char '/'+    <*> packSome (A.satisfy (/= '/'))++getProjectPath :: (Has HerculesClientToken r, Has HerculesClientEnv r) => Maybe ProjectPath -> RIO r ProjectPath+getProjectPath maybeProjectPathParam =+  case maybeProjectPathParam of+    Nothing -> snd <$> findProjectByCurrentRepo+    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+    Just projectKey -> do+      project <- findProjectByKey projectKey+      pure (Project.id <$> project, projectKey)++findProjectByKey :: (Has HerculesClientToken r, Has HerculesClientEnv r) => ProjectPath -> RIO r (Maybe Project.Project)+findProjectByKey path =+  runHerculesClient+    ( Projects.findProjects+        projectsClient+        (Just $ Name $ projectPathSite path)+        (Just $ Name $ projectPathOwner path)+        (Just $ Name $ projectPathProject path)+    )+    <&> head++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+            }+        )++findProject :: (Has HerculesClientToken r, Has HerculesClientEnv r) => ProjectPath -> RIO r Project.Project+findProject project = do+  rs <-+    runHerculesClient+      ( findProjects+          projectsClient+          (Just $ Name $ projectPathSite project)+          (Just $ Name $ projectPathOwner project)+          (Just $ Name $ projectPathProject project)+      )+  case rs of+    [] -> do+      exitMsg $ "Project not found: " <> show project+    [p] -> pure p+    _ -> do+      exitMsg $ "Project ambiguous: " <> show project
+ src/Hercules/CLI/Secret.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}++module Hercules.CLI.Secret where++import qualified Data.Aeson as A+import qualified Data.Map as M+import qualified Data.Text as T+import Hercules.CLI.Common (exitMsg, runAuthenticated)+import Hercules.CLI.JSON as JSON+import Hercules.CLI.Options (mkCommand)+import Hercules.CLI.Project (ProjectPath (projectPathOwner, projectPathSite), getProjectPath, projectOption)+import qualified Options.Applicative as Optparse+import Protolude+import System.FilePath (takeDirectory, (</>))+import UnliftIO.Directory (XdgDirectory (XdgConfig), createDirectoryIfMissing, doesFileExist, getXdgDirectory)++commandParser, initLocal, add :: Optparse.Parser (IO ())+commandParser =+  Optparse.subparser+    ( mkCommand+        "init-local"+        (Optparse.progDesc "Create a local secrets file in ~/.config/hercules-ci/secrets/<site>/<owner>")+        initLocal+        <> mkCommand+          "add"+          (Optparse.progDesc "Insert a secret into the local secrets file")+          add+    )+initLocal = do+  projectOptionMaybe <- optional projectOption+  pure $ runAuthenticated do+    projectPath <- getProjectPath projectOptionMaybe+    secretsFilePath <- liftIO $ getSecretsFilePath projectPath+    doesFileExist secretsFilePath >>= \case+      True -> do+        putErrText $ "hci: Secrets file already existed. Path: " <> toS secretsFilePath+      False -> do+        liftIO $ createDirectoryIfMissing True (takeDirectory secretsFilePath)+        liftIO $ writeFile secretsFilePath "{}"+        putErrText $ "hci: Secrets file created. Path: " <> toS secretsFilePath+add = do+  projectOptionMaybe <- optional projectOption+  mkJson <- JSON.options+  secretName <- Optparse.strArgument (Optparse.metavar "SECRET_NAME" <> Optparse.help "Organization/account-wide name for the secret")+  pure $ runAuthenticated do+    secretData <- liftIO mkJson+    projectPath <- getProjectPath projectOptionMaybe+    secretsFilePath <- liftIO $ getSecretsFilePath projectPath+    liftIO $+      doesFileExist secretsFilePath >>= \case+        False -> exitMsg $ "No secrets file found. If the account is correct, use `hci init-local`. (path: " <> toS secretsFilePath <> ")"+        True -> pass+    secrets <- liftIO $ readJsonFile secretsFilePath+    case M.lookup secretName secrets of+      Just _ -> do+        exitMsg $ "Secret " <> secretName <> " already exists in " <> toS secretsFilePath <> "."+      Nothing -> pass+    let secrets' = secrets & M.insert secretName (A.object ["kind" A..= A.String "Secret", "data" A..= secretData])+    liftIO $ writeJsonFile secretsFilePath secrets'+    putErrText $ "hci: successfully wrote " <> secretName <> " to " <> toS secretsFilePath+    putErrText "NOTE: Remember to synchronize this file with your agents!"++getSecretsFilePath :: ProjectPath -> IO FilePath+getSecretsFilePath projectPath = do+  dir <- getXdgDirectory XdgConfig "hercules-ci"+  let toPathElement = toS . T.map (\case '/' -> '_'; x -> x)+  pure $ dir </> "secrets" </> toPathElement (projectPathSite projectPath) </> toPathElement (projectPathOwner projectPath) </> "secrets.json"
+ src/Hercules/CLI/State.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}++module Hercules.CLI.State where++import Conduit (ConduitT, mapC, runConduitRes, sinkFile, sourceHandle, stdinC, stdoutC, (.|))+import qualified Hercules.API.Projects.Project as Project+import Hercules.API.State+import Hercules.CLI.Client+import Hercules.CLI.Common (runAuthenticated)+import Hercules.CLI.Options (mkCommand)+import Hercules.CLI.Project (findProject, 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.Conduit ()++commandParser, getCommandParser, putCommandParser :: Optparse.Parser (IO ())+commandParser =+  Optparse.subparser+    ( mkCommand+        "get"+        (Optparse.progDesc "Download a state file")+        getCommandParser+        <> mkCommand+          "put"+          (Optparse.progDesc "Upload a state file")+          putCommandParser+    )+getCommandParser = do+  project <- projectOption+  name <- nameOption+  file <- fileOption+  pure do+    runAuthenticated do+      projectId <- Project.id <$> findProject project+      runHerculesClientStream (getProjectStateData stateClient projectId name) \case+        Left e -> dieWithHttpError e+        Right (Headers r _) -> do+          runConduitRes $+            fromSourceIO r .| mapC fromRawBytes .| case file of+              "-" -> stdoutC+              _ -> sinkFile file+putCommandParser = do+  project <- projectOption+  name <- nameOption+  file <- fileOption+  pure do+    runAuthenticated do+      projectId <- Project.id <$> findProject project+      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 (putProjectStateData stateClient projectId name (toSourceIO stream))+        pass+    putErrText $ "hci: State file upload successful for " <> name++nameOption :: Optparse.Parser Text+nameOption = strOption $ long "name" <> metavar "NAME" <> help "Name of the state file"++fileOption :: Optparse.Parser FilePath+fileOption = strOption $ long "file" <> metavar "FILE" <> help "Local path of the state file or - for stdio" <> completer (bashCompleter "file")
+ test/Hercules/CLI/CredentialsSpec.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE BlockArguments #-}++module Hercules.CLI.CredentialsSpec where++import qualified Data.Map as M+import Hercules.CLI.Credentials+import Test.Hspec+import Test.QuickCheck+import Prelude++spec :: Spec+spec = do+  describe "urlDomain" do+    it "parses the default" \_ -> do+      urlDomain "https://hercules-ci.com" `shouldBe` Right "hercules-ci.com"+    it "parses away trailing slash" \_ -> do+      urlDomain "https://hercules-ci.com/" `shouldBe` Right "hercules-ci.com"+    it "works with http if you really want" \_ -> do+      urlDomain "http://private-hercules-ci.bizz.biz" `shouldBe` Right "private-hercules-ci.bizz.biz"+    it "reports parse error (1)" \_ -> do+      urlDomain "aburaoernqeg9" `shouldBe` Left "could not parse HERCULES_CI_API_BASE_URL"+    it "reports parse error (2)" \_ -> do+      urlDomain "http:///" `shouldBe` Left "HERCULES_CI_API_BASE_URL domain name must not be empty"+    it "reports parse error (3)" \_ -> do+      urlDomain "http:/" `shouldBe` Left "HERCULES_CI_API_BASE_URL has no domain/authority part"+  describe "parseCredentials" do+    it "parses v0 format (empty)" \_ -> do+      fmap Blind (parseCredentials "path" "{ \"domains\": {} }") `shouldBe` fmap Blind (Right (Credentials mempty))+    it "parses v0 format" \_ -> do+      fmap Blind (parseCredentials "path" "{ \"domains\": { \"hercules-ci.com\": { \"personalToken\": \"tok\" } } }")+        `shouldBe` fmap Blind (Right (Credentials $ M.singleton "hercules-ci.com" (DomainCredentials {personalToken = "tok"})))
+ test/Hercules/CLI/JSONSpec.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE OverloadedStrings #-}++module Hercules.CLI.JSONSpec (spec) where++import Data.Aeson+import qualified Data.ByteString.Lazy as BL+import Hercules.CLI.JSON+import Protolude+import Test.Hspec++parse :: BL.ByteString -> Either Text Value+parse = f . eitherDecode+  where+    f (Left e) = Left (toS e)+    f (Right r) = Right r++spec :: Spec+spec = do+  describe "mergeObject" do+    it "merges distinct values" \_ -> do+      mergePaths+        [ (["a"], toJSON True),+          (["b"], toJSON [False])+        ]+        `shouldBe` parse "{\"a\": true, \"b\": [false]}"++    it "merges nested values" \_ -> do+      mergePaths+        [ (["x", "a"], toJSON True),+          (["x", "b"], toJSON [False])+        ]+        `shouldBe` parse "{\"x\": {\"a\": true, \"b\": [false]} }"++    it "merges overlapping objects with distinct attrs" \_ -> do+      mergePaths+        [ (["x"], object ["a" .= toJSON True]),+          (["x"], object ["b" .= toJSON [False]])+        ]+        `shouldBe` parse "{\"x\": {\"a\": true, \"b\": [false]} }"++    it "refuses overlapping objects with overlapping attrs" \_ -> do+      mergePaths+        [ (["x"], object ["a" .= toJSON True]),+          (["x"], object ["a" .= toJSON [False]])+        ]+        `shouldBe` Left "Conflicting values for x.a"++    it "merges overlapping objects with distinct attrs" \_ -> do+      mergePaths+        [ (["x"], object ["a" .= toJSON True]),+          ([], object ["x" .= object ["b" .= toJSON [False]]])+        ]+        `shouldBe` parse "{\"x\": {\"a\": true, \"b\": [false]} }"
+ test/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import qualified Spec+import Test.Hspec.Runner+import Prelude++main :: IO ()+main = hspecWith config Spec.spec+  where+    config = defaultConfig {configColorMode = ColorAlways}
+ test/Spec.hs view
@@ -0,0 +1,11 @@+module Spec where++import Hercules.CLI.CredentialsSpec+import Hercules.CLI.JSONSpec+import Test.Hspec+import Prelude++spec :: Spec+spec = describe "The CLI" $ do+  Hercules.CLI.CredentialsSpec.spec+  Hercules.CLI.JSONSpec.spec