{-# 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."
writeSecrets ::
(KatipContext m) =>
Bool ->
Maybe SecretContext ->
Maybe FilePath ->
Map Text SecretRef ->
Map Text (Sensitive Formats.Secret.Secret) ->
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,
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
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,
:: [(Text, Text)],
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
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"),
(Text
"NIX_BUILD_CORES", Text
"1"),
(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]
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
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")
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
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]
++ [
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
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
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
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
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
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_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
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 ()
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
Just AsyncCancelled
AsyncCancelled -> Maybe SomeException
forall a. Maybe a
Nothing
Maybe AsyncCancelled
Nothing | SomeException -> Bool
forall e. Exception e => e -> Bool
isAsyncException SomeException
e -> Maybe SomeException
forall a. Maybe a
Nothing
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
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)