{-# 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.NixFile (getOnPushOutputValueByPath)
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.Common (runAuthenticated)
import Hercules.CLI.Exception (exitMsg)
import Hercules.CLI.Git (getAllBranches, getHypotheticalRefs)
import qualified Hercules.CLI.Git as Git
import Hercules.CLI.Nix (ciNixAttributeCompleter, computeRef, createHerculesCIArgs, resolveInputs, withNix)
import Hercules.CLI.Options (flatCompleter, mkCommand, subparser)
import Hercules.CLI.Project (ProjectPath, getProjectIdAndPath, projectOption, projectPathOwner, projectPathProject, 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 (RunEffectParams (..), runEffect)
import Hercules.Error (escalate)
import qualified Hercules.Secrets as Secret
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, askUnliftIO)
import UnliftIO.Async (wait, withAsync)
import UnliftIO.Directory (createDirectoryIfMissing, getAppUserDataDirectory)
import UnliftIO.Temporary (withTempDirectory)

commandParser, runParser :: Optparse.Parser (IO ())
commandParser :: Parser (IO ())
commandParser =
  Mod CommandFields (IO ()) -> Parser (IO ())
forall a. Mod CommandFields a -> Parser a
subparser
    ( FilePath
-> InfoMod (IO ()) -> Parser (IO ()) -> Mod CommandFields (IO ())
forall a. FilePath -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
        FilePath
"run"
        (FilePath -> InfoMod (IO ())
forall a. FilePath -> InfoMod a
Optparse.progDesc FilePath
"Run an effect")
        Parser (IO ())
runParser
    )
runParser :: Parser (IO ())
runParser = do
  Text
attr <- Parser Text
ciAttributeArgument
  Maybe ProjectPath
projectOptionMaybe <- Parser ProjectPath -> Parser (Maybe ProjectPath)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ProjectPath
projectOption
  Maybe Text
refMaybe <- Parser (Maybe Text)
asRefOptions
  Bool
requireToken <- Bool -> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> a -> Mod FlagFields a -> Parser a
Optparse.flag Bool
True Bool
False (FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"no-token" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Don't get an API token. Disallows access to state files, but can run in untrusted environment or unconfigured repo.")
  pure $ RIO (HerculesClientToken, HerculesClientEnv) () -> IO ()
forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticated do
    RIO (HerculesClientToken, HerculesClientEnv) ProjectData
-> (Async ProjectData
    -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (Maybe ProjectPath
-> Bool -> RIO (HerculesClientToken, HerculesClientEnv) ProjectData
forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Maybe ProjectPath -> Bool -> RIO r ProjectData
getProjectEffectData Maybe ProjectPath
projectOptionMaybe Bool
requireToken) \Async ProjectData
projectPathAsync -> do
      (Store
 -> Ptr EvalState
 -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) b.
MonadUnliftIO m =>
(Store -> Ptr EvalState -> m b) -> m b
withNix \Store
store Ptr EvalState
evalState -> do
        Text
ref <- IO Text -> RIO (HerculesClientToken, HerculesClientEnv) Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> RIO (HerculesClientToken, HerculesClientEnv) Text)
-> IO Text -> RIO (HerculesClientToken, HerculesClientEnv) Text
forall a b. (a -> b) -> a -> b
$ Maybe Text -> IO Text
computeRef Maybe Text
refMaybe
        Bool
isDefaultBranch <- IO Bool -> RIO (HerculesClientToken, HerculesClientEnv) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
Git.getIsDefault
        HerculesCIArgs
args <- IO HerculesCIArgs
-> RIO (HerculesClientToken, HerculesClientEnv) HerculesCIArgs
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HerculesCIArgs
 -> RIO (HerculesClientToken, HerculesClientEnv) HerculesCIArgs)
-> IO HerculesCIArgs
-> RIO (HerculesClientToken, HerculesClientEnv) HerculesCIArgs
forall a b. (a -> b) -> a -> b
$ Maybe Text -> IO HerculesCIArgs
createHerculesCIArgs (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ref)
        let attrPath :: [Text]
attrPath = (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') Text
attr
            nixFile :: Text
nixFile = GitSource -> Text
GitSource.outPath (GitSource -> Text) -> GitSource -> Text
forall a b. (a -> b) -> a -> b
$ HerculesCIArgs -> GitSource
HerculesCIArgs.primaryRepo HerculesCIArgs
args
        UnliftIO (RIO (HerculesClientToken, HerculesClientEnv))
uio <- RIO
  (HerculesClientToken, HerculesClientEnv)
  (UnliftIO (RIO (HerculesClientToken, HerculesClientEnv)))
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
        Maybe RawValue
valMaybe <- IO (Maybe RawValue)
-> RIO (HerculesClientToken, HerculesClientEnv) (Maybe RawValue)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe RawValue)
 -> RIO (HerculesClientToken, HerculesClientEnv) (Maybe RawValue))
-> IO (Maybe RawValue)
-> RIO (HerculesClientToken, HerculesClientEnv) (Maybe RawValue)
forall a b. (a -> b) -> a -> b
$ Ptr EvalState
-> FilePath
-> HerculesCIArgs
-> (Map ByteString InputDeclaration -> IO (Value NixAttrs))
-> [ByteString]
-> IO (Maybe RawValue)
getOnPushOutputValueByPath Ptr EvalState
evalState (Text -> FilePath
forall a b. ConvertText a b => a -> b
toS Text
nixFile) HerculesCIArgs
args (UnliftIO (RIO (HerculesClientToken, HerculesClientEnv))
-> Ptr EvalState
-> Maybe ProjectPath
-> Map ByteString InputDeclaration
-> IO (Value NixAttrs)
forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
UnliftIO (RIO r)
-> Ptr EvalState
-> Maybe ProjectPath
-> Map ByteString InputDeclaration
-> IO (Value NixAttrs)
resolveInputs UnliftIO (RIO (HerculesClientToken, HerculesClientEnv))
uio Ptr EvalState
evalState Maybe ProjectPath
projectOptionMaybe) ((Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> ByteString
encodeUtf8 [Text]
attrPath)
        -- valMaybe <- liftIO $ attrByPath evalState rootValue
        Match
attrValue <- case Maybe RawValue
valMaybe of
          Maybe RawValue
Nothing -> do
            Text -> RIO (HerculesClientToken, HerculesClientEnv) Match
forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg (Text -> RIO (HerculesClientToken, HerculesClientEnv) Match)
-> Text -> RIO (HerculesClientToken, HerculesClientEnv) Match
forall a b. (a -> b) -> a -> b
$ Text
"Could not find an attribute at path " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show [Text]
attrPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nixFile
          Just RawValue
v -> IO (Either SomeException Match)
-> RIO
     (HerculesClientToken, HerculesClientEnv)
     (Either SomeException Match)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr EvalState -> RawValue -> IO (Either SomeException Match)
match Ptr EvalState
evalState RawValue
v) RIO
  (HerculesClientToken, HerculesClientEnv)
  (Either SomeException Match)
-> (Either SomeException Match
    -> RIO (HerculesClientToken, HerculesClientEnv) Match)
-> RIO (HerculesClientToken, HerculesClientEnv) Match
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either SomeException Match
-> RIO (HerculesClientToken, HerculesClientEnv) Match
forall exc (m :: * -> *) a.
(Exception exc, MonadThrow m) =>
Either exc a -> m a
escalate
        Value NixAttrs
effectAttrs <- case Match
attrValue of
          IsAttrs Value NixAttrs
attrs -> Value NixAttrs
-> RIO (HerculesClientToken, HerculesClientEnv) (Value NixAttrs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixAttrs
attrs
          Match
_ -> do
            Text
-> RIO (HerculesClientToken, HerculesClientEnv) (Value NixAttrs)
forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg (Text
 -> RIO (HerculesClientToken, HerculesClientEnv) (Value NixAttrs))
-> Text
-> RIO (HerculesClientToken, HerculesClientEnv) (Value NixAttrs)
forall a b. (a -> b) -> a -> b
$ Text
"Attribute is not an Effect at path " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show [Text]
attrPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nixFile

        Maybe Bool
isEffect <- IO (Maybe Bool)
-> RIO (HerculesClientToken, HerculesClientEnv) (Maybe Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Bool)
 -> RIO (HerculesClientToken, HerculesClientEnv) (Maybe Bool))
-> IO (Maybe Bool)
-> RIO (HerculesClientToken, HerculesClientEnv) (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Ptr EvalState
-> Value NixAttrs
-> ByteString
-> IO (Either SomeException (Maybe Bool))
getAttrBool Ptr EvalState
evalState Value NixAttrs
effectAttrs ByteString
"isEffect" IO (Either SomeException (Maybe Bool))
-> (Either SomeException (Maybe Bool) -> IO (Maybe Bool))
-> IO (Maybe Bool)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either SomeException (Maybe Bool) -> IO (Maybe Bool)
forall exc (m :: * -> *) a.
(Exception exc, MonadThrow m) =>
Either exc a -> m a
escalate
        Bool
-> RIO (HerculesClientToken, HerculesClientEnv) ()
-> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Bool
isEffect Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) do
          Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg (Text -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall a b. (a -> b) -> a -> b
$ Text
"Attribute is not an Effect at path " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show [Text]
attrPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nixFile
        StorePath
drvPath <- Ptr EvalState
-> RawValue
-> RIO (HerculesClientToken, HerculesClientEnv) StorePath
forall (m :: * -> *).
MonadIO m =>
Ptr EvalState -> RawValue -> m StorePath
getDrvFile Ptr EvalState
evalState (Value NixAttrs -> RawValue
forall a. Value a -> RawValue
rtValue Value NixAttrs
effectAttrs)
        Derivation
derivation <- Store
-> StorePath
-> RIO (HerculesClientToken, HerculesClientEnv) Derivation
forall (m :: * -> *).
MonadIO m =>
Store -> StorePath -> m Derivation
prepareDerivation Store
store StorePath
drvPath
        Text
apiBaseURL <- IO Text -> RIO (HerculesClientToken, HerculesClientEnv) Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Text
determineDefaultApiBaseUrl
        ProjectData {pdProjectPath :: ProjectData -> Maybe ProjectPath
pdProjectPath = Maybe ProjectPath
projectPath, pdProjectId :: ProjectData -> Maybe (Id "project")
pdProjectId = Maybe (Id "project")
projectId, pdToken :: ProjectData -> Maybe (Sensitive Text)
pdToken = Maybe (Sensitive Text)
token} <- Async ProjectData
-> RIO (HerculesClientToken, HerculesClientEnv) ProjectData
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async ProjectData
projectPathAsync
        Maybe FilePath
secretsJson <- IO (Maybe FilePath)
-> RIO (HerculesClientToken, HerculesClientEnv) (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilePath)
 -> RIO (HerculesClientToken, HerculesClientEnv) (Maybe FilePath))
-> IO (Maybe FilePath)
-> RIO (HerculesClientToken, HerculesClientEnv) (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ (ProjectPath -> IO FilePath)
-> Maybe ProjectPath -> IO (Maybe FilePath)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ProjectPath -> IO FilePath
getSecretsFilePath Maybe ProjectPath
projectPath
        LogEnv
logEnv <- IO LogEnv -> RIO (HerculesClientToken, HerculesClientEnv) LogEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LogEnv -> RIO (HerculesClientToken, HerculesClientEnv) LogEnv)
-> IO LogEnv -> RIO (HerculesClientToken, HerculesClientEnv) LogEnv
forall a b. (a -> b) -> a -> b
$ Namespace -> Environment -> IO LogEnv
initLogEnv Namespace
forall a. Monoid a => a
mempty Environment
"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
        FilePath
dataDir <- IO FilePath
-> RIO (HerculesClientToken, HerculesClientEnv) FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath
 -> RIO (HerculesClientToken, HerculesClientEnv) FilePath)
-> IO FilePath
-> RIO (HerculesClientToken, HerculesClientEnv) FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
getAppUserDataDirectory FilePath
"hercules-ci"
        Bool -> FilePath -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
True FilePath
dataDir
        let secretContextMaybe :: Maybe SecretContext
secretContextMaybe =
              Maybe ProjectPath
projectPath Maybe ProjectPath
-> (ProjectPath -> SecretContext) -> Maybe SecretContext
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ProjectPath
p ->
                SecretContext :: Text -> Text -> Bool -> Text -> SecretContext
Secret.SecretContext
                  { ownerName :: Text
ownerName = ProjectPath -> Text
projectPathOwner ProjectPath
p,
                    repoName :: Text
repoName = ProjectPath -> Text
projectPathProject ProjectPath
p,
                    isDefaultBranch :: Bool
isDefaultBranch = Bool
isDefaultBranch,
                    ref :: Text
ref = Text
ref
                  }
        ExitCode
exitCode <- FilePath
-> FilePath
-> (FilePath
    -> RIO (HerculesClientToken, HerculesClientEnv) ExitCode)
-> RIO (HerculesClientToken, HerculesClientEnv) ExitCode
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> FilePath -> (FilePath -> m a) -> m a
withTempDirectory FilePath
dataDir FilePath
"tmp-effect-" \FilePath
workDir -> do
          LogEnv
-> ()
-> Namespace
-> KatipContextT
     (RIO (HerculesClientToken, HerculesClientEnv)) ExitCode
-> RIO (HerculesClientToken, HerculesClientEnv) ExitCode
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
logEnv () Namespace
forall a. Monoid a => a
mempty (KatipContextT
   (RIO (HerculesClientToken, HerculesClientEnv)) ExitCode
 -> RIO (HerculesClientToken, HerculesClientEnv) ExitCode)
-> KatipContextT
     (RIO (HerculesClientToken, HerculesClientEnv)) ExitCode
-> RIO (HerculesClientToken, HerculesClientEnv) ExitCode
forall a b. (a -> b) -> a -> b
$
            RunEffectParams
-> KatipContextT
     (RIO (HerculesClientToken, HerculesClientEnv)) ExitCode
forall (m :: * -> *).
(MonadThrow m, KatipContext m) =>
RunEffectParams -> m ExitCode
runEffect
              RunEffectParams :: Derivation
-> Maybe (Sensitive Text)
-> Maybe FilePath
-> Maybe SecretContext
-> Text
-> FilePath
-> Maybe (Id "project")
-> Maybe Text
-> Bool
-> [(Text, Text)]
-> Bool
-> RunEffectParams
RunEffectParams
                { runEffectDerivation :: Derivation
runEffectDerivation = Derivation
derivation,
                  runEffectToken :: Maybe (Sensitive Text)
runEffectToken = Maybe (Sensitive Text)
token,
                  runEffectSecretsConfigPath :: Maybe FilePath
runEffectSecretsConfigPath = Maybe FilePath
secretsJson,
                  runEffectApiBaseURL :: Text
runEffectApiBaseURL = Text
apiBaseURL,
                  runEffectDir :: FilePath
runEffectDir = FilePath
workDir,
                  runEffectProjectId :: Maybe (Id "project")
runEffectProjectId = Maybe (Id "project")
projectId,
                  runEffectProjectPath :: Maybe Text
runEffectProjectPath = ProjectPath -> Text
projectPathText (ProjectPath -> Text) -> Maybe ProjectPath -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ProjectPath
projectPath,
                  runEffectSecretContext :: Maybe SecretContext
runEffectSecretContext = Maybe SecretContext
secretContextMaybe,
                  runEffectUseNixDaemonProxy :: Bool
runEffectUseNixDaemonProxy = Bool
False, -- FIXME Enable proxy for ci/dev parity. Requires access to agent binaries. Unified executable?
                  runEffectExtraNixOptions :: [(Text, Text)]
runEffectExtraNixOptions = [],
                  runEffectFriendly :: Bool
runEffectFriendly = Bool
True
                }
        ExitCode -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ExitCode
exitCode

prepareDerivation :: MonadIO m => Store -> StorePath -> m Derivation
prepareDerivation :: forall (m :: * -> *).
MonadIO m =>
Store -> StorePath -> m Derivation
prepareDerivation Store
store StorePath
drvPath = do
  Derivation
derivation <- IO Derivation -> m Derivation
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Derivation -> m Derivation) -> IO Derivation -> m Derivation
forall a b. (a -> b) -> a -> b
$ Store -> StorePath -> IO Derivation
CNix.getDerivation Store
store StorePath
drvPath
  [(StorePath, [ByteString])]
inputs <- IO [(StorePath, [ByteString])] -> m [(StorePath, [ByteString])]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(StorePath, [ByteString])] -> m [(StorePath, [ByteString])])
-> IO [(StorePath, [ByteString])] -> m [(StorePath, [ByteString])]
forall a b. (a -> b) -> a -> b
$ Store -> Derivation -> IO [(StorePath, [ByteString])]
getDerivationInputs Store
store Derivation
derivation
  StdVector NixStorePathWithOutputs
storePathsWithOutputs <- IO (StdVector NixStorePathWithOutputs)
-> m (StdVector NixStorePathWithOutputs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (StdVector NixStorePathWithOutputs)
forall a. HasStdVector a => IO (StdVector a)
Std.Vector.new
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [(StorePath, [ByteString])]
-> ((StorePath, [ByteString]) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(StorePath, [ByteString])]
inputs \(StorePath
input, [ByteString]
outputs) -> do
    StorePathWithOutputs
swo <- StorePath -> [ByteString] -> IO StorePathWithOutputs
newStorePathWithOutputs StorePath
input [ByteString]
outputs
    StdVector NixStorePathWithOutputs -> StorePathWithOutputs -> IO ()
forall a' a.
(Coercible a' (ForeignPtr a), HasStdVector a) =>
StdVector a -> a' -> IO ()
Std.Vector.pushBackFP StdVector NixStorePathWithOutputs
storePathsWithOutputs StorePathWithOutputs
swo
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Store -> StdVector NixStorePathWithOutputs -> IO ()
buildPaths Store
store StdVector NixStorePathWithOutputs
storePathsWithOutputs
  pure Derivation
derivation

ciAttributeArgument :: Optparse.Parser Text
ciAttributeArgument :: Parser Text
ciAttributeArgument =
  Mod ArgumentFields Text -> Parser Text
forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument (Mod ArgumentFields Text -> Parser Text)
-> Mod ArgumentFields Text -> Parser Text
forall a b. (a -> b) -> a -> b
$
    FilePath -> Mod ArgumentFields Text
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"CI_NIX_ATTRIBUTE"
      Mod ArgumentFields Text
-> Mod ArgumentFields Text -> Mod ArgumentFields Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod ArgumentFields Text
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Attribute to run"
      Mod ArgumentFields Text
-> Mod ArgumentFields Text -> Mod ArgumentFields Text
forall a. Semigroup a => a -> a -> a
<> Completer -> Mod ArgumentFields Text
forall (f :: * -> *) a. HasCompleter f => Completer -> Mod f a
completer Completer
ciNixAttributeCompleter

asBranchOption :: Optparse.Parser Text
asBranchOption :: Parser Text
asBranchOption = Mod OptionFields Text -> Parser Text
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Mod OptionFields Text -> Parser Text)
-> Mod OptionFields Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"as-branch" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"BRANCH" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Pretend we're on another git branch" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> Completer -> Mod OptionFields Text
forall (f :: * -> *) a. HasCompleter f => Completer -> Mod f a
completer (IO [Text] -> Completer
flatCompleter IO [Text]
getAllBranches)

asRefOption :: Optparse.Parser Text
asRefOption :: Parser Text
asRefOption = Mod OptionFields Text -> Parser Text
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Mod OptionFields Text -> Parser Text)
-> Mod OptionFields Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"as-ref" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"REF" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Pretend we're on another git ref" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> Completer -> Mod OptionFields Text
forall (f :: * -> *) a. HasCompleter f => Completer -> Mod f a
completer (IO [Text] -> Completer
flatCompleter IO [Text]
getHypotheticalRefs)

asRefOptions :: Optparse.Parser (Maybe Text)
asRefOptions :: Parser (Maybe Text)
asRefOptions = Parser Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Text
asRefOption Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Text
"refs/heads/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
asBranchOption))

data ProjectData = ProjectData
  { ProjectData -> Maybe ProjectPath
pdProjectPath :: Maybe ProjectPath,
    ProjectData -> Maybe (Id "project")
pdProjectId :: Maybe (Id "project"),
    ProjectData -> Maybe (Sensitive Text)
pdToken :: Maybe (Sensitive Text)
  }

getProjectEffectData :: (Has HerculesClientToken r, Has HerculesClientEnv r) => Maybe ProjectPath -> Bool -> RIO r ProjectData
getProjectEffectData :: forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Maybe ProjectPath -> Bool -> RIO r ProjectData
getProjectEffectData Maybe ProjectPath
maybeProjectPathParam Bool
requireToken = do
  (Maybe (Id Project)
projectIdMaybe, ProjectPath
path) <- Maybe ProjectPath -> RIO r (Maybe (Id Project), ProjectPath)
forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Maybe ProjectPath -> RIO r (Maybe (Id Project), ProjectPath)
getProjectIdAndPath Maybe ProjectPath
maybeProjectPathParam
  if Bool
requireToken
    then do
      Id Project
projectId <- case Maybe (Id Project)
projectIdMaybe of
        Just Id Project
x -> Id Project -> RIO r (Id Project)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id Project
x
        Maybe (Id Project)
Nothing -> do
          Text -> RIO r (Id Project)
forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg (Text -> RIO r (Id Project)) -> Text -> RIO r (Id Project)
forall a b. (a -> b) -> a -> b
$ Text
"Can not access " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ProjectPath -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show ProjectPath
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Make sure you have installed Hercules CI on the organization and repository and that you have access to it."
      CreateUserEffectTokenResponse
response <- (Token -> ClientM CreateUserEffectTokenResponse)
-> RIO r CreateUserEffectTokenResponse
forall a r.
(NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM a) -> RIO r a
runHerculesClient (ProjectsAPI ClientAuth (AsClientT ClientM)
-> AsClientT ClientM
   :- (Summary "Create a token for local effect execution"
       :> ("projects"
           :> (Capture' '[Required, Strict] "projectId" (Id Project)
               :> (ClientAuth
                   :> ("create-user-effect-token"
                       :> Post '[JSON] CreateUserEffectTokenResponse)))))
forall auth f.
ProjectsAPI auth f
-> f
   :- (Summary "Create a token for local effect execution"
       :> ("projects"
           :> (Capture' '[Required, Strict] "projectId" (Id Project)
               :> (auth
                   :> ("create-user-effect-token"
                       :> Post '[JSON] CreateUserEffectTokenResponse)))))
Projects.createUserEffectToken ProjectsAPI ClientAuth (AsClientT ClientM)
projectsClient Id Project
projectId)
      let token :: Sensitive Text
token = Text -> Sensitive Text
forall a. a -> Sensitive a
Sensitive (CreateUserEffectTokenResponse -> Text
CreateUserEffectTokenResponse.token CreateUserEffectTokenResponse
response)
      ProjectData -> RIO r ProjectData
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectData :: Maybe ProjectPath
-> Maybe (Id "project") -> Maybe (Sensitive Text) -> ProjectData
ProjectData {pdProjectPath :: Maybe ProjectPath
pdProjectPath = ProjectPath -> Maybe ProjectPath
forall a. a -> Maybe a
Just ProjectPath
path, pdProjectId :: Maybe (Id "project")
pdProjectId = Id "project" -> Maybe (Id "project")
forall a. a -> Maybe a
Just (Id "project" -> Maybe (Id "project"))
-> Id "project" -> Maybe (Id "project")
forall a b. (a -> b) -> a -> b
$ UUID -> Id "project"
forall k (a :: k). UUID -> Id a
Id (UUID -> Id "project") -> UUID -> Id "project"
forall a b. (a -> b) -> a -> b
$ Id Project -> UUID
forall k (a :: k). Id a -> UUID
idUUID Id Project
projectId, pdToken :: Maybe (Sensitive Text)
pdToken = Sensitive Text -> Maybe (Sensitive Text)
forall a. a -> Maybe a
Just Sensitive Text
token}
    else
      ProjectData -> RIO r ProjectData
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ProjectData :: Maybe ProjectPath
-> Maybe (Id "project") -> Maybe (Sensitive Text) -> ProjectData
ProjectData
          { pdProjectPath :: Maybe ProjectPath
pdProjectPath = Maybe ProjectPath
forall a. Maybe a
Nothing,
            pdProjectId :: Maybe (Id "project")
pdProjectId = Maybe (Id "project")
forall a. Maybe a
Nothing,
            pdToken :: Maybe (Sensitive Text)
pdToken = Maybe (Sensitive Text)
forall a. Maybe a
Nothing
          }