{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Hercules.CLI.Effect where

import qualified Data.Aeson as A
import qualified Data.ByteString as BS
import Data.Has (Has)
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.AttributeEffectEvent as AttributeEffectEvent
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 (getVirtualValueByPath)
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 (runAuthenticatedOrDummy)
import Hercules.CLI.Exception (exitMsg)
import Hercules.CLI.Git (getAllBranches, getHypotheticalRefs)
import qualified Hercules.CLI.Git as Git
import Hercules.CLI.JSON (askPasswordWithKey)
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 (EvalState, Match (IsAttrs), Value (rtValue), getAttrBool, getDrvFile, match)
import qualified Hercules.CNix.Std.Vector as Std.Vector
import Hercules.CNix.Store (Derivation, buildPaths, getDerivationInputs, newStorePathWithOutputs)
import qualified Hercules.CNix.Store as CNix
import Hercules.Effect (RunEffectParams (..), parseDrvSecretsMap, 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 $ Bool -> RIO (HerculesClientToken, HerculesClientEnv) () -> IO ()
forall b.
Bool -> RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticatedOrDummy Bool
requireToken do
    let getProjectInfo :: RIO (HerculesClientToken, HerculesClientEnv) ProjectData
getProjectInfo =
          case Maybe ProjectPath
projectOptionMaybe of
            Just ProjectPath
x
              | Bool -> Bool
not Bool
requireToken ->
                ProjectData
-> RIO (HerculesClientToken, HerculesClientEnv) 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
x,
                      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
                    }
            Maybe ProjectPath
_ -> 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
    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 RIO (HerculesClientToken, HerculesClientEnv) ProjectData
getProjectInfo \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
        Derivation
derivation <- Store
-> Ptr EvalState
-> Maybe ProjectPath
-> Text
-> Text
-> RIO (HerculesClientToken, HerculesClientEnv) Derivation
getEffectDrv Store
store Ptr EvalState
evalState Maybe ProjectPath
projectOptionMaybe Text
ref Text
attr
        Bool
isDefaultBranch <-
          if Bool
requireToken
            then IO Bool -> RIO (HerculesClientToken, HerculesClientEnv) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
Git.getIsDefault
            else Bool -> RIO (HerculesClientToken, HerculesClientEnv) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

        Map ByteString ByteString
drvEnv <- IO (Map ByteString ByteString)
-> RIO
     (HerculesClientToken, HerculesClientEnv)
     (Map ByteString ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map ByteString ByteString)
 -> RIO
      (HerculesClientToken, HerculesClientEnv)
      (Map ByteString ByteString))
-> IO (Map ByteString ByteString)
-> RIO
     (HerculesClientToken, HerculesClientEnv)
     (Map ByteString ByteString)
forall a b. (a -> b) -> a -> b
$ Derivation -> IO (Map ByteString ByteString)
CNix.getDerivationEnv Derivation
derivation
        Map Text SecretRef
secretsMap <- case Map ByteString ByteString -> Either Text (Map Text SecretRef)
parseDrvSecretsMap Map ByteString ByteString
drvEnv of
          Left Text
e -> Text
-> RIO
     (HerculesClientToken, HerculesClientEnv) (Map Text SecretRef)
forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg Text
e
          Right Map Text SecretRef
r -> Map Text SecretRef
-> RIO
     (HerculesClientToken, HerculesClientEnv) (Map Text SecretRef)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text SecretRef
r
        Sensitive (Map Text (Map Text Value))
serverSecrets <- Map Text SecretRef
-> RIO
     (HerculesClientToken, HerculesClientEnv)
     (Sensitive (Map Text (Map Text Value)))
forall r.
Map Text SecretRef -> RIO r (Sensitive (Map Text (Map Text Value)))
loadServerSecrets Map Text SecretRef
secretsMap

        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
-> Sensitive (Map Text (Map Text Value))
-> 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,
                  runEffectServerSecrets :: Sensitive (Map Text (Map Text Value))
runEffectServerSecrets = Sensitive (Map Text (Map Text Value))
serverSecrets,
                  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

loadServerSecrets :: Map Text AttributeEffectEvent.SecretRef -> RIO r (Sensitive (Map Text (Map Text A.Value)))
loadServerSecrets :: forall r.
Map Text SecretRef -> RIO r (Sensitive (Map Text (Map Text Value)))
loadServerSecrets Map Text SecretRef
secrets = Map Text SecretRef
secrets Map Text SecretRef
-> (Map Text SecretRef -> RIO r (Map Text (Map Text Value)))
-> RIO r (Map Text (Map Text Value))
forall a b. a -> (a -> b) -> b
& (Text -> SecretRef -> RIO r (Maybe (Map Text Value)))
-> Map Text SecretRef -> RIO r (Map Text (Map Text Value))
forall (f :: * -> *) k a b.
Applicative f =>
(k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)
M.traverseMaybeWithKey Text -> SecretRef -> RIO r (Maybe (Map Text Value))
forall r. Text -> SecretRef -> RIO r (Maybe (Map Text Value))
loadServerSecret RIO r (Map Text (Map Text Value))
-> (Map Text (Map Text Value)
    -> Sensitive (Map Text (Map Text Value)))
-> RIO r (Sensitive (Map Text (Map Text Value)))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Map Text (Map Text Value) -> Sensitive (Map Text (Map Text Value))
forall a. a -> Sensitive a
Sensitive

loadServerSecret :: Text -> AttributeEffectEvent.SecretRef -> RIO r (Maybe (Map Text A.Value))
loadServerSecret :: forall r. Text -> SecretRef -> RIO r (Maybe (Map Text Value))
loadServerSecret Text
name SecretRef
sr = case SecretRef
sr of
  AttributeEffectEvent.SimpleSecret SimpleSecret
_ -> Maybe (Map Text Value) -> RIO r (Maybe (Map Text Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map Text Value)
forall a. Maybe a
Nothing
  AttributeEffectEvent.GitToken GitToken
gitToken -> Text -> GitToken -> RIO r (Maybe (Map Text Value))
forall r. Text -> GitToken -> RIO r (Maybe (Map Text Value))
loadGitToken Text
name GitToken
gitToken

loadGitToken :: Text -> AttributeEffectEvent.GitToken -> RIO r (Maybe (Map Text A.Value))
loadGitToken :: forall r. Text -> GitToken -> RIO r (Maybe (Map Text Value))
loadGitToken Text
name GitToken
_noDetail = do
  -- TODO: read gh hosts.yaml file?
  (Text, Text)
token <- IO (Text, Text) -> RIO r (Text, Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Text, Text) -> RIO r (Text, Text))
-> IO (Text, Text) -> RIO r (Text, Text)
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Text -> IO (Text, Text)
askPasswordWithKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name) Text
"token"
  Map Text Value -> RIO r (Maybe (Map Text Value))
forall (f :: * -> *) (g :: * -> *) a.
(Applicative f, Applicative g) =>
a -> f (g a)
purer (Map Text Value -> RIO r (Maybe (Map Text Value)))
-> Map Text Value -> RIO r (Maybe (Map Text Value))
forall a b. (a -> b) -> a -> b
$
    [(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      [(Text, Text)
token (Text, Text) -> (Text -> Value) -> (Text, Value)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> Value
A.String]

getEffectDrv :: Store -> Ptr EvalState -> Maybe ProjectPath -> Text -> Text -> RIO (HerculesClientToken, HerculesClientEnv) Derivation
getEffectDrv :: Store
-> Ptr EvalState
-> Maybe ProjectPath
-> Text
-> Text
-> RIO (HerculesClientToken, HerculesClientEnv) Derivation
getEffectDrv Store
store Ptr EvalState
evalState Maybe ProjectPath
projectOptionMaybe Text
ref Text
attr = do
  ByteString
storeDir <- IO ByteString
-> RIO (HerculesClientToken, HerculesClientEnv) ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString
 -> RIO (HerculesClientToken, HerculesClientEnv) ByteString)
-> IO ByteString
-> RIO (HerculesClientToken, HerculesClientEnv) ByteString
forall a b. (a -> b) -> a -> b
$ Store -> IO ByteString
forall (m :: * -> *). MonadIO m => Store -> m ByteString
CNix.storeDir Store
store
  Derivation
derivation <-
    if OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
storeDir Text -> Text -> Bool
`T.isPrefixOf` Text
attr
      then IO Derivation
-> RIO (HerculesClientToken, HerculesClientEnv) Derivation
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Derivation
 -> RIO (HerculesClientToken, HerculesClientEnv) Derivation)
-> IO Derivation
-> RIO (HerculesClientToken, HerculesClientEnv) Derivation
forall a b. (a -> b) -> a -> b
$ do
        -- Support derivation in arbitrary location
        -- Used in hercules-ci-effects test runner
        let path :: Text
path = Text
attr
        ByteString
contents <- FilePath -> IO ByteString
BS.readFile (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
forall a b. ConvertText a b => a -> b
toS Text
path
        let stripDrv :: Text -> Text
stripDrv Text
s = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
s (Text -> Text -> Maybe Text
T.stripSuffix Text
".drv" Text
s)
        Store -> ByteString -> ByteString -> IO Derivation
CNix.getDerivationFromString Store
store (Text
path Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& (Char -> Bool) -> Text -> Text
T.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text
stripDrv Text -> (Text -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Text -> ByteString
encodeUtf8) ByteString
contents
      else Ptr EvalState
-> Store
-> Maybe ProjectPath
-> Text
-> Text
-> RIO (HerculesClientToken, HerculesClientEnv) Derivation
forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Ptr EvalState
-> Store -> Maybe ProjectPath -> Text -> Text -> RIO r Derivation
evaluateEffectDerivation Ptr EvalState
evalState Store
store Maybe ProjectPath
projectOptionMaybe Text
ref Text
attr
  Store
-> Derivation -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *). MonadIO m => Store -> Derivation -> m ()
prepareDerivation Store
store Derivation
derivation
  pure Derivation
derivation

evaluateEffectDerivation :: (Has HerculesClientToken r, Has HerculesClientEnv r) => Ptr EvalState -> Store -> Maybe ProjectPath -> Text -> Text -> RIO r Derivation
evaluateEffectDerivation :: forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Ptr EvalState
-> Store -> Maybe ProjectPath -> Text -> Text -> RIO r Derivation
evaluateEffectDerivation Ptr EvalState
evalState Store
store Maybe ProjectPath
projectOptionMaybe Text
ref Text
attr = do
  HerculesCIArgs
args <- IO HerculesCIArgs -> RIO r HerculesCIArgs
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HerculesCIArgs -> RIO r HerculesCIArgs)
-> IO HerculesCIArgs -> RIO r 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 r)
uio <- RIO r (UnliftIO (RIO r))
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
  Maybe RawValue
valMaybe <- IO (Maybe RawValue) -> RIO r (Maybe RawValue)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe RawValue) -> RIO r (Maybe RawValue))
-> IO (Maybe RawValue) -> RIO r (Maybe RawValue)
forall a b. (a -> b) -> a -> b
$ Ptr EvalState
-> FilePath
-> HerculesCIArgs
-> (Map ByteString InputDeclaration -> IO (Value NixAttrs))
-> [ByteString]
-> IO (Maybe RawValue)
getVirtualValueByPath Ptr EvalState
evalState (Text -> FilePath
forall a b. ConvertText a b => a -> b
toS Text
nixFile) HerculesCIArgs
args (UnliftIO (RIO r)
-> 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 r)
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 r Match
forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg (Text -> RIO r Match) -> Text -> RIO r 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, StringConv 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 r (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 r (Either SomeException Match)
-> (Either SomeException Match -> RIO r Match) -> RIO r Match
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either SomeException Match -> RIO r 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 r (Value NixAttrs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixAttrs
attrs
    Match
_ -> do
      Text -> RIO r (Value NixAttrs)
forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg (Text -> RIO r (Value NixAttrs)) -> Text -> RIO r (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, StringConv 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 r (Maybe Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Bool) -> RIO r (Maybe Bool))
-> IO (Maybe Bool) -> RIO r (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 r () -> RIO r ()
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 r ()
forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg (Text -> RIO r ()) -> Text -> RIO r ()
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, StringConv 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 r 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)
  IO Derivation -> RIO r Derivation
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Derivation -> RIO r Derivation)
-> IO Derivation -> RIO r Derivation
forall a b. (a -> b) -> a -> b
$ Store -> StorePath -> IO Derivation
CNix.getDerivation Store
store StorePath
drvPath

prepareDerivation :: MonadIO m => Store -> Derivation -> m ()
prepareDerivation :: forall (m :: * -> *). MonadIO m => Store -> Derivation -> m ()
prepareDerivation Store
store Derivation
derivation = do
  [(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

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, StringConv 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
          }