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

module Hercules.Effect where

import Control.Concurrent.Async (AsyncCancelled (AsyncCancelled))
import Control.Exception.Safe (isAsyncException)
import Control.Monad.Catch (MonadThrow)
import Data.Aeson qualified as A
import Data.Aeson.KeyMap qualified as AK
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.Map qualified as M
import Data.Text qualified as T
import Hercules.API.Agent.Evaluate.EvaluateEvent.AttributeEffectEvent (GitToken (..), SecretRef (GitToken, SimpleSecret), SimpleSecret (MkSimpleSecret))
import Hercules.API.Agent.Evaluate.EvaluateEvent.AttributeEffectEvent qualified
import Hercules.API.Id (Id, idText)
import Hercules.Agent.Sensitive (Sensitive (Sensitive, reveal), revealContainer)
import Hercules.Agent.WorkerProcess qualified as WorkerProcess
import Hercules.CNix (Derivation)
import Hercules.CNix.Store (getDerivationArguments, getDerivationBuilder, getDerivationEnv)
import Hercules.Effect.Container (BindMount (BindMount))
import Hercules.Effect.Container qualified as Container
import Hercules.Error (escalateAs)
import Hercules.Formats.Mountable (Mountable)
import Hercules.Formats.Mountable qualified as Mountable
import Hercules.Formats.Secret qualified as Formats.Secret
import Hercules.Secrets (SecretContext, evalCondition, evalConditionTrace)
import Katip (KatipContext, Severity (..), logLocM, logStr)
import Network.Socket (Family (AF_UNIX), SockAddr (SockAddrUnix), SocketType (Stream), bind, listen, socket, withFdSocket)
import Protolude
import System.FilePath
import System.IO.Error (isDoesNotExistError)
import System.Posix (dup, fdToHandle)
import System.Posix.Signals (killProcess, signalProcess)
import System.Posix.User (getEffectiveGroupID, getEffectiveUserID)
import System.Process (ProcessHandle)
import System.Process.Internals qualified as Process.Internal
import UnliftIO.Directory (createDirectory, createDirectoryIfMissing)
import UnliftIO.Process (withCreateProcess)
import UnliftIO.Process qualified as Process

parseDrvMountsMap :: Map ByteString ByteString -> Either Text (Map Text Text)
parseDrvMountsMap :: Map ByteString ByteString -> Either Text (Map Text Text)
parseDrvMountsMap Map ByteString ByteString
drvEnv =
  case ByteString
"__hci_effect_mounts" ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map ByteString ByteString
drvEnv of
    Maybe ByteString
Nothing -> Map Text Text -> Either Text (Map Text Text)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text Text
forall a. Monoid a => a
mempty
    Just ByteString
mountsMapText -> case ByteString -> Either String (Map Text Text)
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (ByteString -> ByteString
BL.fromStrict ByteString
mountsMapText) of
      Left String
e -> Text -> Either Text (Map Text Text)
forall a b. a -> Either a b
Left (Text -> Either Text (Map Text Text))
-> Text -> Either Text (Map Text Text)
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse __hci_effect_mounts variable in derivation. Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertText a b => a -> b
toS String
e
      Right Map Text Text
r -> Map Text Text -> Either Text (Map Text Text)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text Text
r

parseDrvSecretsMap :: Map ByteString ByteString -> Either Text (Map Text SecretRef)
parseDrvSecretsMap :: Map ByteString ByteString -> Either Text (Map Text SecretRef)
parseDrvSecretsMap Map ByteString ByteString
drvEnv =
  case (,) Text
"secretsToUse" (ByteString -> (Text, ByteString))
-> Maybe ByteString -> Maybe (Text, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ByteString
"secretsToUse" Map ByteString ByteString
drvEnv
    Maybe (Text, ByteString)
-> Maybe (Text, ByteString) -> Maybe (Text, ByteString)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (,) Text
"secretsMap" (ByteString -> (Text, ByteString))
-> Maybe ByteString -> Maybe (Text, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ByteString
"secretsMap" Map ByteString ByteString
drvEnv of
    Maybe (Text, ByteString)
Nothing -> Map Text SecretRef -> Either Text (Map Text SecretRef)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text SecretRef
forall a. Monoid a => a
mempty
    Just (Text
attrName, ByteString
secretsMapText) -> case ByteString -> Either String Object
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (ByteString -> ByteString
BL.fromStrict ByteString
secretsMapText) of
      Left String
e -> Text -> Either Text (Map Text SecretRef)
forall a b. a -> Either a b
Left (Text -> Either Text (Map Text SecretRef))
-> Text -> Either Text (Map Text SecretRef)
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" variable in derivation. Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertText a b => a -> b
toS String
e
      Right Object
r -> Text -> Object -> Either Text (Map Text SecretRef)
parseSecretRefs Text
attrName Object
r

parseSecretRefs :: Text -> A.Object -> Either Text (Map Text SecretRef)
parseSecretRefs :: Text -> Object -> Either Text (Map Text SecretRef)
parseSecretRefs Text
attrName Object
obj =
  Object -> Map Text Value
forall v. KeyMap v -> Map Text v
AK.toMapText Object
obj Map Text Value
-> (Map Text Value -> Either Text (Map Text SecretRef))
-> Either Text (Map Text SecretRef)
forall a b. a -> (a -> b) -> b
& (Text -> Value -> Either Text SecretRef)
-> Map Text Value -> Either Text (Map Text SecretRef)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
M.traverseWithKey \Text
k Value
v -> Text -> Value -> Either Text SecretRef
parseSecretRef (Text
attrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k) Value
v

parseSecretRef :: Text -> A.Value -> Either Text SecretRef
parseSecretRef :: Text -> Value -> Either Text SecretRef
parseSecretRef Text
_ (A.String Text
s) = SecretRef -> Either Text SecretRef
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SimpleSecret -> SecretRef
SimpleSecret (SimpleSecret -> SecretRef) -> SimpleSecret -> SecretRef
forall a b. (a -> b) -> a -> b
$ Text -> SimpleSecret
MkSimpleSecret Text
s)
parseSecretRef Text
attrName (A.Object Object
o) =
  case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
AK.lookup Key
"type" Object
o of
    Just (A.String Text
s) ->
      case Text
s of
        Text
"GitToken" -> SecretRef -> Either Text SecretRef
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GitToken -> SecretRef
GitToken (GitToken -> SecretRef) -> GitToken -> SecretRef
forall a b. (a -> b) -> a -> b
$ MkGitToken {})
        Text
_ -> Text -> Either Text SecretRef
forall a b. a -> Either a b
Left (Text -> Either Text SecretRef) -> Text -> Either Text SecretRef
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse secret reference " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", because the type is unknown; must be \"GitToken\"."
    Just Value
_ -> Text -> Either Text SecretRef
forall a b. a -> Either a b
Left (Text -> Either Text SecretRef) -> Text -> Either Text SecretRef
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse secret reference " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", because the type attribute is not a string."
    Maybe Value
Nothing -> Text -> Either Text SecretRef
forall a b. a -> Either a b
Left (Text -> Either Text SecretRef) -> Text -> Either Text SecretRef
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse secret reference " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", because it does not have a type attribute."
parseSecretRef Text
attrName Value
_ = Text -> Either Text SecretRef
forall a b. a -> Either a b
Left (Text -> Either Text SecretRef) -> Text -> Either Text SecretRef
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse secret reference " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", because it is neither a string nor an attribute set."

-- | Write secrets to file based on secretsMap value
writeSecrets ::
  (KatipContext m) =>
  -- | Whether we're in a friendly context, such as the CLI.
  Bool ->
  Maybe SecretContext ->
  -- | Optional source file
  Maybe FilePath ->
  -- | Declared secrets from the effect derivation
  Map Text SecretRef ->
  -- | Local secrets
  Map Text (Sensitive Formats.Secret.Secret) ->
  -- | Server secrets
  Map Text (Sensitive (Map Text A.Value)) ->
  FilePath ->
  m ()
writeSecrets :: forall (m :: * -> *).
KatipContext m =>
Bool
-> Maybe SecretContext
-> Maybe String
-> Map Text SecretRef
-> Map Text (Sensitive Secret)
-> Map Text (Sensitive (Map Text Value))
-> String
-> m ()
writeSecrets Bool
friendly Maybe SecretContext
ctxMaybe Maybe String
sourceFileMaybe Map Text SecretRef
secretsMap Map Text (Sensitive Secret)
extraSecrets Map Text (Sensitive (Map Text Value))
serverSecrets String
destinationDirectory = Map Text Secret -> m ()
write (Map Text Secret -> m ())
-> (Map Text (Sensitive Secret) -> Map Text Secret)
-> Map Text (Sensitive Secret)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sensitive Secret -> Secret)
-> Map Text (Sensitive Secret) -> Map Text Secret
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Sensitive Secret -> Secret
forall a. Sensitive a -> a
reveal (Map Text (Sensitive Secret) -> Map Text Secret)
-> (Map Text (Sensitive Secret) -> Map Text (Sensitive Secret))
-> Map Text (Sensitive Secret)
-> Map Text Secret
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text (Sensitive Secret) -> Map Text (Sensitive Secret)
addExtra (Map Text (Sensitive Secret) -> m ())
-> m (Map Text (Sensitive Secret)) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Map Text (Sensitive Secret))
gather
  where
    addExtra :: Map Text (Sensitive Secret) -> Map Text (Sensitive Secret)
addExtra = (Map Text (Sensitive Secret)
 -> Map Text (Sensitive Secret) -> Map Text (Sensitive Secret))
-> Map Text (Sensitive Secret)
-> Map Text (Sensitive Secret)
-> Map Text (Sensitive Secret)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Map Text (Sensitive Secret)
-> Map Text (Sensitive Secret) -> Map Text (Sensitive Secret)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map Text (Sensitive Secret)
extraSecrets
    write :: Map Text Secret -> m ()
write = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (Map Text Secret -> IO ()) -> Map Text Secret -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString -> IO ()
BS.writeFile (String
destinationDirectory String -> String -> String
</> String
"secrets.json") (ByteString -> IO ())
-> (Map Text Secret -> ByteString) -> Map Text Secret -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (Map Text Secret -> ByteString) -> Map Text Secret -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Secret -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode
    gather :: m (Map Text (Sensitive Secret))
gather =
      if Map Text SecretRef -> Bool
forall a. Map Text a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text SecretRef
secretsMap
        then Map Text (Sensitive Secret) -> m (Map Text (Sensitive Secret))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text (Sensitive Secret)
forall a. Monoid a => a
mempty
        else do
          Sensitive (Map Text Secret)
allSecrets <-
            Maybe String
sourceFileMaybe Maybe String
-> (Maybe String -> m (Sensitive (Map Text Secret)))
-> m (Sensitive (Map Text Secret))
forall a b. a -> (a -> b) -> b
& m (Sensitive (Map Text Secret))
-> (String -> m (Sensitive (Map Text Secret)))
-> Maybe String
-> m (Sensitive (Map Text Secret))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Map Text Secret -> m (Sensitive (Map Text Secret))
forall (f :: * -> *) (g :: * -> *) a.
(Applicative f, Applicative g) =>
a -> f (g a)
purer Map Text Secret
forall a. Monoid a => a
mempty) \String
sourceFile -> do
              ByteString
secretsBytes <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
sourceFile
              case ByteString -> Either String (Map Text Secret)
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (ByteString -> Either String (Map Text Secret))
-> ByteString -> Either String (Map Text Secret)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
secretsBytes of
                Left String
e -> do
                  Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Severity -> LogStr -> m ()
logLocM Severity
ErrorS (LogStr -> m ()) -> LogStr -> m ()
forall a b. (a -> b) -> a -> b
$ LogStr
"Could not parse secrets file " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr String
sourceFile LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
": " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr String
e
                  FatalError -> m (Sensitive (Map Text Secret))
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FatalError -> m (Sensitive (Map Text Secret)))
-> FatalError -> m (Sensitive (Map Text Secret))
forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError Text
"Could not parse secrets file as configured on agent."
                Right Map Text Secret
r -> Sensitive (Map Text Secret) -> m (Sensitive (Map Text Secret))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text Secret -> Sensitive (Map Text Secret)
forall a. a -> Sensitive a
Sensitive Map Text Secret
r)

          Bool -> String -> m ()
forall (m :: * -> *). MonadIO m => Bool -> String -> m ()
createDirectoryIfMissing Bool
True String
destinationDirectory

          Map Text SecretRef
secretsMap Map Text SecretRef
-> (Map Text SecretRef -> m (Map Text (Sensitive Secret)))
-> m (Map Text (Sensitive Secret))
forall a b. a -> (a -> b) -> b
& (Text -> SecretRef -> m (Sensitive Secret))
-> Map Text SecretRef -> m (Map Text (Sensitive Secret))
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
M.traverseWithKey \Text
destinationName SecretRef
secretRef ->
            case SecretRef
secretRef of
              GitToken {} -> do
                case Text
-> Map Text (Sensitive (Map Text Value))
-> Maybe (Sensitive (Map Text Value))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
destinationName Map Text (Sensitive (Map Text Value))
serverSecrets of
                  Just Sensitive (Map Text Value)
x -> Sensitive Secret -> m (Sensitive Secret)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sensitive (Map Text Value)
x Sensitive (Map Text Value)
-> (Map Text Value -> Secret) -> Sensitive Secret
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Map Text Value
data_ -> Formats.Secret.Secret {data_ :: Map Text Value
data_ = Map Text Value
data_, condition :: Maybe Condition
condition = Condition -> Maybe Condition
forall a. a -> Maybe a
Just ([Condition] -> Condition
Formats.Secret.And [])})
                  Maybe (Sensitive (Map Text Value))
Nothing ->
                    IO (Sensitive Secret) -> m (Sensitive Secret)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Sensitive Secret) -> m (Sensitive Secret))
-> (Text -> IO (Sensitive Secret)) -> Text -> m (Sensitive Secret)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FatalError -> IO (Sensitive Secret)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FatalError -> IO (Sensitive Secret))
-> (Text -> FatalError) -> Text -> IO (Sensitive Secret)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FatalError
FatalError (Text -> m (Sensitive Secret)) -> Text -> m (Sensitive Secret)
forall a b. (a -> b) -> a -> b
$
                      Text
"A value for secret " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
destinationName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" was not provided. This may be a bug."
              SimpleSecret (MkSimpleSecret {name :: SimpleSecret -> Text
name = Text
secretName}) -> do
                let gotoFail :: Text -> m a
gotoFail Text
name =
                      IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (Text -> IO a) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FatalError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FatalError -> IO a) -> (Text -> FatalError) -> Text -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FatalError
FatalError (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$
                        Text
"Secret " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" does not exist or access was denied, so we can't get a secret for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
destinationName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Please make sure that the secret name matches a secret on your agents and make sure that its condition applies."

                case Sensitive (Maybe Secret) -> Maybe (Sensitive Secret)
forall (f :: * -> *) a.
Functor f =>
Sensitive (f a) -> f (Sensitive a)
revealContainer (Sensitive (Map Text Secret)
allSecrets Sensitive (Map Text Secret)
-> (Map Text Secret -> Maybe Secret) -> Sensitive (Maybe Secret)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> Map Text Secret -> Maybe Secret
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
secretName) of
                  Maybe (Sensitive Secret)
Nothing -> Text -> m (Sensitive Secret)
forall {m :: * -> *} {a}. MonadIO m => Text -> m a
gotoFail Text
secretName
                  Just Sensitive Secret
ssecret -> do
                    let condMaybe :: Maybe Condition
condMaybe = Sensitive (Maybe Condition) -> Maybe Condition
forall a. Sensitive a -> a
reveal (Secret -> Maybe Condition
Formats.Secret.condition (Secret -> Maybe Condition)
-> Sensitive Secret -> Sensitive (Maybe Condition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sensitive Secret
ssecret)
                        r :: Sensitive Secret
r = do
                          Secret
secret <- Sensitive Secret
ssecret
                          Secret -> Sensitive Secret
forall a. a -> Sensitive a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Secret -> Sensitive Secret) -> Secret -> Sensitive Secret
forall a b. (a -> b) -> a -> b
$
                            Formats.Secret.Secret
                              { data_ :: Map Text Value
data_ = Secret -> Map Text Value
Formats.Secret.data_ Secret
secret,
                                -- Hide the condition
                                condition :: Maybe Condition
condition = Maybe Condition
forall a. Maybe a
Nothing
                              }
                    case (Bool
friendly, Maybe Condition
condMaybe) of
                      (Bool
True, Maybe Condition
Nothing) -> do
                        Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"The secret " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Text
secretName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" does not contain the `condition` field, which is required on hercules-ci-agent >= 0.9."
                        Sensitive Secret -> m (Sensitive Secret)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sensitive Secret
r
                      (Bool
True, Just Condition
cond) | Just SecretContext
ctx <- Maybe SecretContext
ctxMaybe ->
                        case SecretContext -> Condition -> ([Text], Bool)
evalConditionTrace SecretContext
ctx Condition
cond of
                          ([Text]
_, Bool
True) -> Sensitive Secret -> m (Sensitive Secret)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sensitive Secret
r
                          ([Text]
trace_, Bool
_) -> do
                            Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Could not grant access to secret " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Text
secretName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
                            [Text] -> (Text -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Text]
trace_ \Text
ln -> Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ln
                            IO (Sensitive Secret) -> m (Sensitive Secret)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Sensitive Secret) -> m (Sensitive Secret))
-> (Text -> IO (Sensitive Secret)) -> Text -> m (Sensitive Secret)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FatalError -> IO (Sensitive Secret)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FatalError -> IO (Sensitive Secret))
-> (Text -> FatalError) -> Text -> IO (Sensitive Secret)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FatalError
FatalError (Text -> m (Sensitive Secret)) -> Text -> m (Sensitive Secret)
forall a b. (a -> b) -> a -> b
$ Text
"Could not grant access to secret " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Text
secretName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". See trace in preceding log."
                      (Bool
True, Just Condition
_) | Bool
otherwise -> do
                        -- This is only ok in friendly mode (hci)
                        Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"WARNING: not performing secrets access control. The secret.condition field won't be checked."
                        Sensitive Secret -> m (Sensitive Secret)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sensitive Secret
r
                      (Bool
False, Maybe Condition
Nothing) -> Text -> m (Sensitive Secret)
forall {m :: * -> *} {a}. MonadIO m => Text -> m a
gotoFail Text
secretName
                      (Bool
False, Just Condition
cond) ->
                        if SecretContext -> Condition -> Bool
evalCondition (SecretContext -> Maybe SecretContext -> SecretContext
forall a. a -> Maybe a -> a
fromMaybe (Text -> SecretContext
forall a. HasCallStack => Text -> a
panic Text
"SecretContext is required") Maybe SecretContext
ctxMaybe) Condition
cond then Sensitive Secret -> m (Sensitive Secret)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sensitive Secret
r else Text -> m (Sensitive Secret)
forall {m :: * -> *} {a}. MonadIO m => Text -> m a
gotoFail Text
secretName

data RunEffectParams = RunEffectParams
  { RunEffectParams -> Derivation
runEffectDerivation :: Derivation,
    RunEffectParams -> Maybe (Sensitive Text)
runEffectToken :: Maybe (Sensitive Text),
    RunEffectParams -> Maybe String
runEffectSecretsConfigPath :: Maybe FilePath,
    RunEffectParams -> Maybe SecretContext
runEffectSecretContext :: Maybe SecretContext,
    RunEffectParams -> Sensitive (Map Text (Map Text Value))
runEffectServerSecrets :: Sensitive (Map Text (Map Text A.Value)),
    RunEffectParams -> Sensitive (Map Text Mountable)
runEffectConfiguredMountables :: Sensitive (Map Text Mountable),
    RunEffectParams -> Text
runEffectApiBaseURL :: Text,
    RunEffectParams -> String
runEffectDir :: FilePath,
    RunEffectParams -> Maybe (Id "project")
runEffectProjectId :: Maybe (Id "project"),
    RunEffectParams -> Maybe Text
runEffectProjectPath :: Maybe Text,
    RunEffectParams -> Bool
runEffectUseNixDaemonProxy :: Bool,
    RunEffectParams -> [(Text, Text)]
runEffectExtraNixOptions :: [(Text, Text)],
    -- | Whether we can relax security in favor of usability; 'True' in @hci effect run@. 'False' in agent.
    RunEffectParams -> Bool
runEffectFriendly :: Bool
  }

(=:) :: k -> a -> Map k a
=: :: forall k a. k -> a -> Map k a
(=:) = k -> a -> Map k a
forall k a. k -> a -> Map k a
M.singleton

runEffect :: (MonadThrow m, KatipContext m) => RunEffectParams -> m ExitCode
runEffect :: forall (m :: * -> *).
(MonadThrow m, KatipContext m) =>
RunEffectParams -> m ExitCode
runEffect p :: RunEffectParams
p@RunEffectParams {runEffectDerivation :: RunEffectParams -> Derivation
runEffectDerivation = Derivation
derivation, runEffectSecretsConfigPath :: RunEffectParams -> Maybe String
runEffectSecretsConfigPath = Maybe String
secretsPath, runEffectApiBaseURL :: RunEffectParams -> Text
runEffectApiBaseURL = Text
apiBaseURL, runEffectDir :: RunEffectParams -> String
runEffectDir = String
dir, runEffectServerSecrets :: RunEffectParams -> Sensitive (Map Text (Map Text Value))
runEffectServerSecrets = Sensitive (Map Text (Map Text Value))
serverSecrets} = do
  ByteString
drvBuilder <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Derivation -> IO ByteString
getDerivationBuilder Derivation
derivation
  [ByteString]
drvArgs <- IO [ByteString] -> m [ByteString]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ByteString] -> m [ByteString])
-> IO [ByteString] -> m [ByteString]
forall a b. (a -> b) -> a -> b
$ Derivation -> IO [ByteString]
getDerivationArguments Derivation
derivation
  Map ByteString ByteString
drvEnv <- IO (Map ByteString ByteString) -> m (Map ByteString ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map ByteString ByteString) -> m (Map ByteString ByteString))
-> IO (Map ByteString ByteString) -> m (Map ByteString ByteString)
forall a b. (a -> b) -> a -> b
$ Derivation -> IO (Map ByteString ByteString)
getDerivationEnv Derivation
derivation
  Map Text SecretRef
drvSecretsMap <- (Text -> FatalError)
-> Either Text (Map Text SecretRef) -> m (Map Text SecretRef)
forall exc (m :: * -> *) l a.
(Exception exc, MonadThrow m) =>
(l -> exc) -> Either l a -> m a
escalateAs Text -> FatalError
FatalError (Either Text (Map Text SecretRef) -> m (Map Text SecretRef))
-> Either Text (Map Text SecretRef) -> m (Map Text SecretRef)
forall a b. (a -> b) -> a -> b
$ Map ByteString ByteString -> Either Text (Map Text SecretRef)
parseDrvSecretsMap Map ByteString ByteString
drvEnv
  Map Text Text
drvMountsMap <- (Text -> FatalError)
-> Either Text (Map Text Text) -> m (Map Text Text)
forall exc (m :: * -> *) l a.
(Exception exc, MonadThrow m) =>
(l -> exc) -> Either l a -> m a
escalateAs Text -> FatalError
FatalError (Either Text (Map Text Text) -> m (Map Text Text))
-> Either Text (Map Text Text) -> m (Map Text Text)
forall a b. (a -> b) -> a -> b
$ Map ByteString ByteString -> Either Text (Map Text Text)
parseDrvMountsMap Map ByteString ByteString
drvEnv
  let mkDir :: String -> f a
mkDir String
d = let newDir :: String
newDir = String
dir String -> String -> String
</> String
d in String -> a
forall a b. ConvertText a b => a -> b
toS String
newDir a -> f () -> f a
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> f ()
forall (m :: * -> *). MonadIO m => String -> m ()
createDirectory String
newDir
  Text
buildDir <- String -> m Text
forall {f :: * -> *} {a}.
(ConvertText String a, MonadIO f) =>
String -> f a
mkDir String
"build"
  Text
etcDir <- String -> m Text
forall {f :: * -> *} {a}.
(ConvertText String a, MonadIO f) =>
String -> f a
mkDir String
"etc"
  Text
secretsDir <- String -> m Text
forall {f :: * -> *} {a}.
(ConvertText String a, MonadIO f) =>
String -> f a
mkDir String
"secrets"
  String
containerDir <- String -> m String
forall {f :: * -> *} {a}.
(ConvertText String a, MonadIO f) =>
String -> f a
mkDir String
"container-state"
  let extraSecrets :: Map Text (Sensitive Secret)
extraSecrets =
        RunEffectParams -> Maybe (Sensitive Text)
runEffectToken RunEffectParams
p
          Maybe (Sensitive Text)
-> (Maybe (Sensitive Text) -> Map Text (Sensitive Secret))
-> Map Text (Sensitive Secret)
forall a b. a -> (a -> b) -> b
& Map Text (Sensitive Secret)
-> (Sensitive Text -> Map Text (Sensitive Secret))
-> Maybe (Sensitive Text)
-> Map Text (Sensitive Secret)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            Map Text (Sensitive Secret)
forall a. Monoid a => a
mempty
            ( \Sensitive Text
token ->
                Text
"hercules-ci" Text -> Sensitive Secret -> Map Text (Sensitive Secret)
forall k a. k -> a -> Map k a
=: do
                  Text
tok <- Sensitive Text
token
                  Secret -> Sensitive Secret
forall a. a -> Sensitive a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Secret -> Sensitive Secret) -> Secret -> Sensitive Secret
forall a b. (a -> b) -> a -> b
$
                    Formats.Secret.Secret
                      { data_ :: Map Text Value
data_ = Text -> Value -> Map Text Value
forall k a. k -> a -> Map k a
M.singleton Text
"token" (Value -> Map Text Value) -> Value -> Map Text Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
A.String Text
tok,
                        condition :: Maybe Condition
condition = Maybe Condition
forall a. Maybe a
Nothing
                      }
            )
  Bool
-> Maybe SecretContext
-> Maybe String
-> Map Text SecretRef
-> Map Text (Sensitive Secret)
-> Map Text (Sensitive (Map Text Value))
-> String
-> m ()
forall (m :: * -> *).
KatipContext m =>
Bool
-> Maybe SecretContext
-> Maybe String
-> Map Text SecretRef
-> Map Text (Sensitive Secret)
-> Map Text (Sensitive (Map Text Value))
-> String
-> m ()
writeSecrets (RunEffectParams -> Bool
runEffectFriendly RunEffectParams
p) (RunEffectParams -> Maybe SecretContext
runEffectSecretContext RunEffectParams
p) Maybe String
secretsPath Map Text SecretRef
drvSecretsMap Map Text (Sensitive Secret)
extraSecrets (Sensitive (Map Text (Map Text Value))
-> Map Text (Sensitive (Map Text Value))
forall (f :: * -> *) a.
Functor f =>
Sensitive (f a) -> f (Sensitive a)
revealContainer Sensitive (Map Text (Map Text Value))
serverSecrets) (Text -> String
forall a b. ConvertText a b => a -> b
toS Text
secretsDir)
  IO ExitCode -> m ExitCode
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExitCode -> m ExitCode) -> IO ExitCode -> m ExitCode
forall a b. (a -> b) -> a -> b
$ do
    -- Nix sandbox sets tmp to buildTopDir
    -- Nix sandbox reference: https://github.com/NixOS/nix/blob/24e07c428f21f28df2a41a7a9851d5867f34753a/src/libstore/build.cc#L2545
    --
    -- TODO: what if we have structuredAttrs?
    -- TODO: implement passAsFile?
    let overridableEnv, onlyImpureOverridableEnv, fixedEnv :: Map Text Text
        overridableEnv :: Map Text Text
overridableEnv =
          [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, Text)] -> Map Text Text)
-> [(Text, Text)] -> Map Text Text
forall a b. (a -> b) -> a -> b
$
            [ (Text
"PATH", Text
"/path-not-set"),
              (Text
"HOME", Text
"/homeless-shelter"),
              (Text
"NIX_STORE", Text
"/nix/store"), -- TODO store.storeDir
              (Text
"NIX_BUILD_CORES", Text
"1"), -- not great
              (Text
"NIX_REMOTE", Text
"daemon"),
              (Text
"IN_HERCULES_CI_EFFECT", Text
"true"),
              (Text
"HERCULES_CI_API_BASE_URL", Text
apiBaseURL),
              (Text
"HERCULES_CI_SECRETS_JSON", Text
"/secrets/secrets.json")
            ]
              [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"HERCULES_CI_PROJECT_ID", Id "project" -> Text
forall {k} (a :: k). Id a -> Text
idText Id "project"
x) | Id "project"
x <- Maybe (Id "project") -> [Id "project"]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe (Id "project") -> [Id "project"])
-> Maybe (Id "project") -> [Id "project"]
forall a b. (a -> b) -> a -> b
$ RunEffectParams -> Maybe (Id "project")
runEffectProjectId RunEffectParams
p]
              [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"HERCULES_CI_PROJECT_PATH", Text
x) | Text
x <- Maybe Text -> [Text]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe Text -> [Text]) -> Maybe Text -> [Text]
forall a b. (a -> b) -> a -> b
$ RunEffectParams -> Maybe Text
runEffectProjectPath RunEffectParams
p]

        -- NB: this is lossy. Consider using ByteString-based process functions
        drvEnv' :: Map Text Text
drvEnv' = Map ByteString ByteString
drvEnv Map ByteString ByteString
-> (Map ByteString ByteString -> Map Text ByteString)
-> Map Text ByteString
forall a b. a -> (a -> b) -> b
& (ByteString -> Text)
-> Map ByteString ByteString -> Map Text ByteString
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode) Map Text ByteString
-> (Map Text ByteString -> Map Text Text) -> Map Text Text
forall a b. a -> (a -> b) -> b
& (ByteString -> Text) -> Map Text ByteString -> Map Text Text
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode)
        impureEnvVars :: Map Text Text
impureEnvVars = Map Text Text
forall a. Monoid a => a
mempty -- TODO
        fixedEnv :: Map Text Text
fixedEnv =
          [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
            [ (Text
"NIX_LOG_FD", Text
"2"),
              (Text
"TERM", Text
"xterm-256color")
            ]
        onlyImpureOverridableEnv :: Map Text Text
onlyImpureOverridableEnv =
          [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
            [ (Text
"NIX_BUILD_TOP", Text
"/build"),
              (Text
"TMPDIR", Text
"/build"),
              (Text
"TEMPDIR", Text
"/build"),
              (Text
"TMP", Text
"/build"),
              (Text
"TEMP", Text
"/build")
            ]

        uid_ :: Int
uid_ = Map Text Text
drvEnv' Map Text Text -> (Map Text Text -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
& Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"__hci_effect_virtual_uid" Maybe Text -> (Maybe Text -> Int) -> Int
forall a b. a -> (a -> b) -> b
& Int -> (Text -> Int) -> Maybe Text -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Text -> Text -> Int
forall {a} {a}.
(Read a, ConvertText a String, Show a) =>
Text -> a -> a
readOrThrow Text
"__hci_effect_virtual_uid as integer")
        gid_ :: Int
gid_ = Map Text Text
drvEnv' Map Text Text -> (Map Text Text -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
& Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"__hci_effect_virtual_gid" Maybe Text -> (Maybe Text -> Int) -> Int
forall a b. a -> (a -> b) -> b
& Int -> (Text -> Int) -> Maybe Text -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
uid_ (Text -> Text -> Int
forall {a} {a}.
(Read a, ConvertText a String, Show a) =>
Text -> a -> a
readOrThrow Text
"__hci_effect_virtual_gid as integer")
        rootReadOnly_ :: Bool
rootReadOnly_ = Map Text Text
drvEnv' Map Text Text -> (Map Text Text -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
& Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"__hci_effect_root_read_only" Maybe Text -> (Maybe Text -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Text -> Text -> Bool
forall {a}. (Eq a, IsString a, Show a) => Text -> a -> Bool
readBool Text
"__hci_effect_root_read_only")

        readOrThrow :: Text -> a -> a
readOrThrow Text
what a
str = case ReadS a
forall a. Read a => ReadS a
reads (a -> String
forall a b. ConvertText a b => a -> b
toS a
str) of
          [(a
x, String
"")] -> a
x
          [(a, String)]
_ -> Text -> a
forall a. HasCallStack => Text -> a
panic (Text
"Could not parse " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from derivation environment. Value was: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a b. (Show a, StringConv String b) => a -> b
show a
str)
        readBool :: Text -> a -> Bool
readBool Text
_ a
"1" = Bool
True
        readBool Text
_ a
"" = Bool
False
        readBool Text
_ a
"true" = Bool
True
        readBool Text
_ a
"false" = Bool
False
        readBool Text
what a
x = Text -> Bool
forall a. HasCallStack => Text -> a
panic (Text
"Could not parse boolean " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from derivation environment. Value was: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a b. (Show a, StringConv String b) => a -> b
show a
x)

        (//) :: (Ord k) => Map k a -> Map k a -> Map k a
        // :: forall k a. Ord k => Map k a -> Map k a -> Map k a
(//) = (Map k a -> Map k a -> Map k a) -> Map k a -> Map k a -> Map k a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Map k a -> Map k a -> Map k a
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union
    let (IO a -> IO a
withNixDaemonProxyPerhaps, String
forwardedSocketPath) =
          if RunEffectParams -> Bool
runEffectUseNixDaemonProxy RunEffectParams
p
            then
              let socketPath :: String
socketPath = String
dir String -> String -> String
</> String
"nix-daemon-socket"
               in ([(Text, Text)] -> String -> IO a -> IO a
forall a. [(Text, Text)] -> String -> IO a -> IO a
withNixDaemonProxy (RunEffectParams -> [(Text, Text)]
runEffectExtraNixOptions RunEffectParams
p) String
socketPath, String
socketPath)
            else (IO a -> IO a
forall a. a -> a
identity, String
"/nix/var/nix/daemon-socket/socket")

    -- Tell the runtime to use the current process' uid/gid
    UserID
hostUID_ <-
      IO UserID
getEffectiveUserID
        IO UserID -> (UserID -> IO UserID) -> IO UserID
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          UserID
0 -> Text -> IO UserID
forall a. HasCallStack => Text -> a
panic Text
"Refusing to host effect as root user"
          UserID
x -> UserID -> IO UserID
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserID
x
    GroupID
hostGID_ <-
      IO GroupID
getEffectiveGroupID
        IO GroupID -> (GroupID -> IO GroupID) -> IO GroupID
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          GroupID
x -> GroupID -> IO GroupID
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupID
x

    [BindMount]
extraBindMounts_ <- Map Text Mountable
-> Maybe SecretContext -> Map Text Text -> IO [BindMount]
checkMounts (Sensitive (Map Text Mountable) -> Map Text Mountable
forall a. Sensitive a -> a
reveal (Sensitive (Map Text Mountable) -> Map Text Mountable)
-> Sensitive (Map Text Mountable) -> Map Text Mountable
forall a b. (a -> b) -> a -> b
$ RunEffectParams -> Sensitive (Map Text Mountable)
runEffectConfiguredMountables RunEffectParams
p) (RunEffectParams -> Maybe SecretContext
runEffectSecretContext RunEffectParams
p) Map Text Text
drvMountsMap
    -- We've validated that the paths are pretty much canonical; otherwise this check would be insufficient.
    let isExtraBind :: Text -> Bool
isExtraBind Text
path = [BindMount]
extraBindMounts_ [BindMount] -> ([BindMount] -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& (BindMount -> Bool) -> [BindMount] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\BindMount
m -> BindMount -> Text
Container.pathInContainer BindMount
m Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
path)
    IO ExitCode -> IO ExitCode
forall {a}. IO a -> IO a
withNixDaemonProxyPerhaps (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$
      String -> Config -> IO ExitCode
Container.run
        String
containerDir
        Container.Config
          { extraBindMounts :: [BindMount]
extraBindMounts =
              [ BindMount {pathInContainer :: Text
pathInContainer = Text
"/build", pathInHost :: Text
pathInHost = Text
buildDir, readOnly :: Bool
readOnly = Bool
False},
                BindMount {pathInContainer :: Text
pathInContainer = Text
"/secrets", pathInHost :: Text
pathInHost = Text
secretsDir, readOnly :: Bool
readOnly = Bool
True},
                BindMount {pathInContainer :: Text
pathInContainer = Text
"/nix/var/nix/daemon-socket/socket", pathInHost :: Text
pathInHost = String -> Text
forall a b. ConvertText a b => a -> b
toS String
forwardedSocketPath, readOnly :: Bool
readOnly = Bool
True}
              ]
                [BindMount] -> [BindMount] -> [BindMount]
forall a. [a] -> [a] -> [a]
++ [ BindMount {pathInContainer :: Text
pathInContainer = Text
"/etc", pathInHost :: Text
pathInHost = Text
etcDir, readOnly :: Bool
readOnly = Bool
False}
                     | Bool -> Bool
not (Text -> Bool
isExtraBind Text
"/etc")
                   ]
                [BindMount] -> [BindMount] -> [BindMount]
forall a. [a] -> [a] -> [a]
++ [
                     -- TODO: does this apply to crun?
                     -- we cannot bind mount this read-only because of https://github.com/opencontainers/runc/issues/1523
                     BindMount {pathInContainer :: Text
pathInContainer = Text
"/etc/resolv.conf", pathInHost :: Text
pathInHost = Text
"/etc/resolv.conf", readOnly :: Bool
readOnly = Bool
False}
                     | Bool -> Bool
not (Text -> Bool
isExtraBind Text
"/etc") Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
isExtraBind Text
"/etc/resolv.conf")
                   ]
                [BindMount] -> [BindMount] -> [BindMount]
forall a. [a] -> [a] -> [a]
++ [BindMount]
extraBindMounts_,
            executable :: Text
executable = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
drvBuilder,
            arguments :: [Text]
arguments = (ByteString -> Text) -> [ByteString] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode) [ByteString]
drvArgs,
            environment :: Map Text Text
environment = Map Text Text
overridableEnv Map Text Text -> Map Text Text -> Map Text Text
forall k a. Ord k => Map k a -> Map k a -> Map k a
// Map Text Text
drvEnv' Map Text Text -> Map Text Text -> Map Text Text
forall k a. Ord k => Map k a -> Map k a -> Map k a
// Map Text Text
onlyImpureOverridableEnv Map Text Text -> Map Text Text -> Map Text Text
forall k a. Ord k => Map k a -> Map k a -> Map k a
// Map Text Text
impureEnvVars Map Text Text -> Map Text Text -> Map Text Text
forall k a. Ord k => Map k a -> Map k a -> Map k a
// Map Text Text
fixedEnv,
            workingDirectory :: Text
workingDirectory = Text
"/build",
            hostname :: Text
hostname = Text
"hercules-ci",
            rootReadOnly :: Bool
rootReadOnly = Bool
rootReadOnly_,
            virtualUID :: Int
virtualUID = Int
uid_,
            virtualGID :: Int
virtualGID = Int
gid_,
            hostUID :: Int
hostUID = UserID -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UserID
hostUID_,
            hostGID :: Int
hostGID = GroupID -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GroupID
hostGID_
          }

checkMounts :: Map Text Mountable -> Maybe SecretContext -> Map Text Text -> IO [BindMount]
checkMounts :: Map Text Mountable
-> Maybe SecretContext -> Map Text Text -> IO [BindMount]
checkMounts Map Text Mountable
configuredMnts Maybe SecretContext
secretContext Map Text Text
drvMounts = do
  [[BindMount]] -> [BindMount]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[BindMount]] -> [BindMount])
-> IO [[BindMount]] -> IO [BindMount]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Text)]
-> ((Text, Text) -> IO [BindMount]) -> IO [[BindMount]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text Text
drvMounts) \(Text
mntPath, Text
mntName) -> do
    let -- Intentionally generic message, as misconfigurations on the agent are somewhat sensitive.
        abort :: IO a
abort = FatalError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FatalError -> IO a) -> FatalError -> IO a
forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError (Text -> FatalError) -> Text -> FatalError
forall a b. (a -> b) -> a -> b
$ Text
"While configuring the mount for effect sandbox path " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Text
mntPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", a mountable with name " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
mntName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has not been configured on agent, or it has been configured, but the condition field does not allow it to be used by this effect invocation. Make sure that mountable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
mntName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" exists in the agent configuration and that its condition field allows it to be used in the context of this job."
    case Text -> Map Text Mountable -> Maybe Mountable
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
mntName Map Text Mountable
configuredMnts of
      Maybe Mountable
Nothing -> do
        IO [BindMount]
forall {a}. IO a
abort
      Just Mountable
mountable -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Text
"/" Text -> Text -> Bool
`T.isPrefixOf` Text
mntPath)) do
          FatalError -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FatalError -> IO ()) -> FatalError -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError (Text
"Mount path must be absolute, but path does not start with /: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Text
mntPath)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
"/." Text -> Text -> Bool
`T.isInfixOf` Text
mntPath) do
          FatalError -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FatalError -> IO ()) -> FatalError -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError (Text
"Mount path must not contain /., but path is: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Text
mntPath)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
"//" Text -> Text -> Bool
`T.isInfixOf` Text
mntPath) do
          FatalError -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FatalError -> IO ()) -> FatalError -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError (Text
"Mount path must not contain //, but path is: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Text
mntPath)
        let -- Only valid after checks above
            checkPrefix :: Text -> f ()
checkPrefix Text
path = do
              Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
mntPath Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
path Bool -> Bool -> Bool
|| (Text
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/") Text -> Text -> Bool
`T.isPrefixOf` Text
mntPath) do
                FatalError -> f ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FatalError -> f ()) -> FatalError -> f ()
forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError (Text
"Mount over " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not allowed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Text
mntPath)
        Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
checkPrefix Text
"/nix"
        Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
checkPrefix Text
"/secrets"
        Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
checkPrefix Text
"/build"

        let cond :: Condition
cond = Mountable -> Condition
Mountable.condition Mountable
mountable
        -- TODO: make hci effect run allow this? allow this when condition is simply `true`?
        SecretContext
ctx <- IO SecretContext
-> (SecretContext -> IO SecretContext)
-> Maybe SecretContext
-> IO SecretContext
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> IO SecretContext
forall a. HasCallStack => Text -> a
panic Text
"No job context provided - don't know whether mounts are allowed.") SecretContext -> IO SecretContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SecretContext
secretContext
        let conditionOk :: Bool
conditionOk = SecretContext -> Condition -> Bool
evalCondition SecretContext
ctx Condition
cond
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
conditionOk) do
          IO ()
forall {a}. IO a
abort
        [BindMount] -> IO [BindMount]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [BindMount {pathInContainer :: Text
pathInContainer = Text
mntPath, pathInHost :: Text
pathInHost = Mountable -> Text
Mountable.source Mountable
mountable, readOnly :: Bool
readOnly = Mountable -> Bool
Mountable.readOnly Mountable
mountable}]

withNixDaemonProxy :: [(Text, Text)] -> FilePath -> IO a -> IO a
withNixDaemonProxy :: forall a. [(Text, Text)] -> String -> IO a -> IO a
withNixDaemonProxy [(Text, Text)]
extraNixOptions String
socketPath IO a
wrappedAction = do
  -- Open the socket asap, so we don't have to wait for
  -- a readiness signal from the daemon, or poll, etc.
  Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_UNIX SocketType
Stream ProtocolNumber
0
  Socket -> SockAddr -> IO ()
bind Socket
sock (String -> SockAddr
SockAddrUnix String
socketPath)
  Socket -> Int -> IO ()
listen Socket
sock Int
100

  -- (Ab)use stdin to transfer the socket while securely
  -- closing all other fds
  Handle
socketAsHandle <- Socket -> (ProtocolNumber -> IO Handle) -> IO Handle
forall r. Socket -> (ProtocolNumber -> IO r) -> IO r
withFdSocket Socket
sock \ProtocolNumber
fd -> do
    Fd
fd' <- Fd -> IO Fd
dup (ProtocolNumber -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral ProtocolNumber
fd)
    Fd -> IO Handle
fdToHandle Fd
fd'

  String
exe <- IO String
forall (m :: * -> *). MonadIO m => m String
WorkerProcess.getDaemonExe
  let opts :: [String]
opts = [(Text, Text)]
extraNixOptions [(Text, Text)] -> ((Text, Text) -> [String]) -> [String]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Text
k, Text
v) -> [String
"--option", Text -> String
forall a b. ConvertText a b => a -> b
toS Text
k, Text -> String
forall a b. ConvertText a b => a -> b
toS Text
v]
      procSpec :: CreateProcess
procSpec =
        (String -> [String] -> CreateProcess
Process.proc String
exe [String]
opts)
          { -- close all other fds to be secure
            close_fds :: Bool
Process.close_fds = Bool
True,
            std_in :: StdStream
Process.std_in = Handle -> StdStream
Process.UseHandle Handle
socketAsHandle,
            std_err :: StdStream
Process.std_err = StdStream
Process.Inherit,
            std_out :: StdStream
Process.std_out = Handle -> StdStream
Process.UseHandle Handle
stderr
          }
  CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> m a)
-> m a
withCreateProcess CreateProcess
procSpec ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
 -> IO a)
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_in Maybe Handle
_out Maybe Handle
_err ProcessHandle
processHandle -> do
    IO a
wrappedAction
      -- TODO kill process _group_?
      IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` ProcessHandle -> IO ()
destroyProcess_1s ProcessHandle
processHandle

forPid :: (Num pid) => ProcessHandle -> (pid -> IO ()) -> IO ()
forPid :: forall pid. Num pid => ProcessHandle -> (pid -> IO ()) -> IO ()
forPid ProcessHandle
ph pid -> IO ()
f = ProcessHandle -> (ProcessHandle__ -> IO ()) -> IO ()
forall a. ProcessHandle -> (ProcessHandle__ -> IO a) -> IO a
Process.Internal.withProcessHandle ProcessHandle
ph \case
  Process.Internal.OpenHandle {phdlProcessHandle :: ProcessHandle__ -> PHANDLE
phdlProcessHandle = PHANDLE
pid} -> pid -> IO ()
f (PHANDLE -> pid
forall a b. (Integral a, Num b) => a -> b
fromIntegral PHANDLE
pid)
  Process.Internal.OpenExtHandle {phdlProcessHandle :: ProcessHandle__ -> PHANDLE
phdlProcessHandle = PHANDLE
pid} -> pid -> IO ()
f (PHANDLE -> pid
forall a b. (Integral a, Num b) => a -> b
fromIntegral PHANDLE
pid)
  Process.Internal.ClosedHandle {} -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Make sure a process is terminated, in about 1s or less.
destroyProcess_1s :: ProcessHandle -> IO ()
destroyProcess_1s :: ProcessHandle -> IO ()
destroyProcess_1s ProcessHandle
ph = do
  ProcessHandle -> IO ()
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ()
Process.terminateProcess ProcessHandle
ph
  let waitp :: IO ExitCode
waitp = ProcessHandle -> IO ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
Process.waitForProcess ProcessHandle
ph
      killp :: IO ()
killp = do
        Int -> IO ()
threadDelay Int
500_000
        ProcessHandle -> IO ()
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ()
Process.terminateProcess ProcessHandle
ph
        Int -> IO ()
threadDelay Int
500_000
        ProcessHandle -> (PHANDLE -> IO ()) -> IO ()
forall pid. Num pid => ProcessHandle -> (pid -> IO ()) -> IO ()
forPid ProcessHandle
ph \PHANDLE
pid ->
          ProtocolNumber -> PHANDLE -> IO ()
signalProcess ProtocolNumber
killProcess PHANDLE
pid
      handleKillException :: IO () -> IO ()
handleKillException =
        (SomeException -> Maybe SomeException)
-> (SomeException -> IO ()) -> IO () -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust
          ( \SomeException
e -> case SomeException -> Maybe AsyncCancelled
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
              -- completely ignore when cancelled by waitp completing early
              Just AsyncCancelled
AsyncCancelled -> Maybe SomeException
forall a. Maybe a
Nothing
              -- completely ignore asynchronous exceptions
              Maybe AsyncCancelled
Nothing | SomeException -> Bool
forall e. Exception e => e -> Bool
isAsyncException SomeException
e -> Maybe SomeException
forall a. Maybe a
Nothing
              -- process may not exist anymore when sending a second signal (or more)
              -- in which case usually waitp will catch that during our threadDelay,
              -- but we shouldn't rely on that, as we don't want to raise false positives.
              Maybe AsyncCancelled
Nothing | Just IOError
e' <- SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e, IOError -> Bool
isDoesNotExistError IOError
e' -> Maybe SomeException
forall a. Maybe a
Nothing
              Maybe AsyncCancelled
Nothing -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
          )
          ( \SomeException
e -> do
              -- TODO katip
              String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
putErrLn (String
"hercules-ci-agent: Ignoring exception while stopping nix-daemon proxy " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)
          )
  IO ExitCode -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
race_ IO ExitCode
waitp (IO ()
killp IO () -> (IO () -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& IO () -> IO ()
handleKillException)