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

module Hercules.Effect where

import Control.Monad.Catch (MonadThrow)
import qualified Data.Aeson as A
import qualified Data.Aeson.KeyMap as AK
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import Hercules.API.Agent.Evaluate.EvaluateEvent.AttributeEffectEvent (GitToken (..), SecretRef (GitToken, SimpleSecret), SimpleSecret (MkSimpleSecret))
import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.AttributeEffectEvent
import Hercules.API.Id (Id, idText)
import Hercules.Agent.Sensitive (Sensitive (Sensitive, reveal), revealContainer)
import qualified Hercules.Agent.WorkerProcess as WorkerProcess
import Hercules.CNix (Derivation)
import Hercules.CNix.Store (getDerivationArguments, getDerivationBuilder, getDerivationEnv)
import Hercules.Effect.Container (BindMount (BindMount))
import qualified Hercules.Effect.Container as Container
import Hercules.Error (escalateAs)
import qualified Hercules.Formats.Secret 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.Posix (dup, fdToHandle)
import UnliftIO.Directory (createDirectory, createDirectoryIfMissing)
import UnliftIO.Process (withCreateProcess)
import qualified UnliftIO.Process as Process

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" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ByteString
"secretsToUse" Map ByteString ByteString
drvEnv
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (,) Text
"secretsMap" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ByteString
"secretsMap" Map ByteString ByteString
drvEnv of
    Maybe (Text, ByteString)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
    Just (Text
attrName, ByteString
secretsMapText) -> case forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (ByteString -> ByteString
BL.fromStrict ByteString
secretsMapText) of
      Left String
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Could not parse " forall a. Semigroup a => a -> a -> a
<> Text
attrName forall a. Semigroup a => a -> a -> a
<> Text
" variable in derivation. It must be a JSON dictionary."
      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 =
  forall v. KeyMap v -> Map Text v
AK.toMapText Object
obj forall a b. a -> (a -> b) -> b
& 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 forall a. Semigroup a => a -> a -> a
<> 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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (SimpleSecret -> SecretRef
SimpleSecret forall a b. (a -> b) -> a -> b
$ Text -> SimpleSecret
MkSimpleSecret Text
s)
parseSecretRef Text
attrName (A.Object Object
o) =
  case 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" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (GitToken -> SecretRef
GitToken forall a b. (a -> b) -> a -> b
$ MkGitToken {})
        Text
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Could not parse secret reference " forall a. Semigroup a => a -> a -> a
<> Text
attrName forall a. Semigroup a => a -> a -> a
<> Text
", because the type is unknown; must be \"GitToken\"."
    Just Value
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Could not parse secret reference " forall a. Semigroup a => a -> a -> a
<> Text
attrName forall a. Semigroup a => a -> a -> a
<> Text
", because the type attribute is not a string."
    Maybe Value
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Could not parse secret reference " forall a. Semigroup a => a -> a -> a
<> Text
attrName forall a. Semigroup a => a -> a -> a
<> Text
", because it does not have a type attribute."
parseSecretRef Text
attrName Value
_ = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Could not parse secret reference " forall a. Semigroup a => a -> a -> a
<> Text
attrName 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 ::
  (MonadIO m, 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 :: * -> *).
(MonadIO 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Sensitive a -> a
reveal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text (Sensitive Secret) -> Map Text (Sensitive Secret)
addExtra 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString -> IO ()
BS.writeFile (String
destinationDirectory String -> String -> String
</> String
"secrets.json") forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
A.encode
    gather :: m (Map Text (Sensitive Secret))
gather =
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text SecretRef
secretsMap
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
        else do
          Sensitive (Map Text Secret)
allSecrets <-
            Maybe String
sourceFileMaybe forall a b. a -> (a -> b) -> b
& forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) (g :: * -> *) a.
(Applicative f, Applicative g) =>
a -> f (g a)
purer forall a. Monoid a => a
mempty) \String
sourceFile -> do
              ByteString
secretsBytes <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
sourceFile
              case forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
secretsBytes of
                Left String
e -> do
                  forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Severity -> LogStr -> m ()
logLocM Severity
ErrorS forall a b. (a -> b) -> a -> b
$ LogStr
"Could not parse secrets file " forall a. Semigroup a => a -> a -> a
<> forall a. StringConv a Text => a -> LogStr
logStr String
sourceFile forall a. Semigroup a => a -> a -> a
<> LogStr
": " forall a. Semigroup a => a -> a -> a
<> forall a. StringConv a Text => a -> LogStr
logStr String
e
                  forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Sensitive a
Sensitive Map Text Secret
r)

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

          Map Text SecretRef
secretsMap forall a b. a -> (a -> b) -> b
& 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 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sensitive (Map Text Value)
x 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 = forall a. a -> Maybe a
Just ([Condition] -> Condition
Formats.Secret.And [])})
                  Maybe (Sensitive (Map Text Value))
Nothing ->
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FatalError
FatalError forall a b. (a -> b) -> a -> b
$
                      Text
"A value for secret " forall a. Semigroup a => a -> a -> a
<> Text
destinationName 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 =
                      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FatalError
FatalError forall a b. (a -> b) -> a -> b
$
                        Text
"Secret " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" does not exist or access was denied, so we can't get a secret for " forall a. Semigroup a => a -> a -> a
<> Text
destinationName 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 forall (f :: * -> *) a.
Functor f =>
Sensitive (f a) -> f (Sensitive a)
revealContainer (Sensitive (Map Text Secret)
allSecrets forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
secretName) of
                  Maybe (Sensitive Secret)
Nothing -> forall {m :: * -> *} {a}. MonadIO m => Text -> m a
gotoFail Text
secretName
                  Just Sensitive Secret
ssecret -> do
                    let condMaybe :: Maybe Condition
condMaybe = forall a. Sensitive a -> a
reveal (Secret -> Maybe Condition
Formats.Secret.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
                          forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall a. Maybe a
Nothing
                              }
                    case (Bool
friendly, Maybe Condition
condMaybe) of
                      (Bool
True, Maybe Condition
Nothing) -> do
                        forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText forall a b. (a -> b) -> a -> b
$ Text
"The secret " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Text
secretName forall a. Semigroup a => a -> a -> a
<> Text
" does not contain the `condition` field, which is required on hercules-ci-agent >= 0.9."
                        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) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Sensitive Secret
r
                          ([Text]
trace_, Bool
_) -> do
                            forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText forall a b. (a -> b) -> a -> b
$ Text
"Could not grant access to secret " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Text
secretName forall a. Semigroup a => a -> a -> a
<> Text
"."
                            forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Text]
trace_ \Text
ln -> forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText forall a b. (a -> b) -> a -> b
$ Text
"  " forall a. Semigroup a => a -> a -> a
<> Text
ln
                            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FatalError
FatalError forall a b. (a -> b) -> a -> b
$ Text
"Could not grant access to secret " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Text
secretName 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)
                        forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"WARNING: not performing secrets access control. The secret.condition field won't be checked."
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure Sensitive Secret
r
                      (Bool
False, Maybe Condition
Nothing) -> forall {m :: * -> *} {a}. MonadIO m => Text -> m a
gotoFail Text
secretName
                      (Bool
False, Just Condition
cond) ->
                        if SecretContext -> Condition -> Bool
evalCondition (forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => Text -> a
panic Text
"SecretContext is required") Maybe SecretContext
ctxMaybe) Condition
cond then forall (f :: * -> *) a. Applicative f => a -> f a
pure Sensitive Secret
r else 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 -> 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
(=:) = 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Derivation -> IO ByteString
getDerivationBuilder Derivation
derivation
  [ByteString]
drvArgs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Derivation -> IO [ByteString]
getDerivationArguments Derivation
derivation
  Map ByteString ByteString
drvEnv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Derivation -> IO (Map ByteString ByteString)
getDerivationEnv Derivation
derivation
  Map Text SecretRef
drvSecretsMap <- forall exc (m :: * -> *) l a.
(Exception exc, MonadThrow m) =>
(l -> exc) -> Either l a -> m a
escalateAs Text -> FatalError
FatalError forall a b. (a -> b) -> a -> b
$ Map ByteString ByteString -> Either Text (Map Text SecretRef)
parseDrvSecretsMap Map ByteString ByteString
drvEnv
  let mkDir :: String -> f a
mkDir String
d = let newDir :: String
newDir = String
dir String -> String -> String
</> String
d in forall a b. ConvertText a b => a -> b
toS String
newDir forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). MonadIO m => String -> m ()
createDirectory String
newDir
  Text
buildDir <- forall {f :: * -> *} {a}.
(ConvertText String a, MonadIO f) =>
String -> f a
mkDir String
"build"
  Text
etcDir <- forall {f :: * -> *} {a}.
(ConvertText String a, MonadIO f) =>
String -> f a
mkDir String
"etc"
  Text
secretsDir <- forall {f :: * -> *} {a}.
(ConvertText String a, MonadIO f) =>
String -> f a
mkDir String
"secrets"
  String
runcDir <- forall {f :: * -> *} {a}.
(ConvertText String a, MonadIO f) =>
String -> f a
mkDir String
"runc-state"
  let extraSecrets :: Map Text (Sensitive Secret)
extraSecrets =
        RunEffectParams -> Maybe (Sensitive Text)
runEffectToken RunEffectParams
p
          forall a b. a -> (a -> b) -> b
& forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            forall a. Monoid a => a
mempty
            ( \Sensitive Text
token ->
                Text
"hercules-ci" forall k a. k -> a -> Map k a
=: do
                  Text
tok <- Sensitive Text
token
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                    Formats.Secret.Secret
                      { data_ :: Map Text Value
data_ = forall k a. k -> a -> Map k a
M.singleton Text
"token" forall a b. (a -> b) -> a -> b
$ Text -> Value
A.String Text
tok,
                        condition :: Maybe Condition
condition = forall a. Maybe a
Nothing
                      }
            )
  forall (m :: * -> *).
(MonadIO 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 (forall (f :: * -> *) a.
Functor f =>
Sensitive (f a) -> f (Sensitive a)
revealContainer Sensitive (Map Text (Map Text Value))
serverSecrets) (forall a b. ConvertText a b => a -> b
toS Text
secretsDir)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 =
          forall k a. Ord k => [(k, a)] -> Map k a
M.fromList 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")
            ]
              forall a. Semigroup a => a -> a -> a
<> [(Text
"HERCULES_CI_PROJECT_ID", forall {k} (a :: k). Id a -> Text
idText Id "project"
x) | Id "project"
x <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ RunEffectParams -> Maybe (Id "project")
runEffectProjectId RunEffectParams
p]
              forall a. Semigroup a => a -> a -> a
<> [(Text
"HERCULES_CI_PROJECT_PATH", Text
x) | Text
x <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList 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 forall a b. a -> (a -> b) -> b
& forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode) forall a b. a -> (a -> b) -> 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 = forall a. Monoid a => a
mempty -- TODO
        fixedEnv :: Map Text Text
fixedEnv =
          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 =
          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")
            ]
        (//) :: 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
(//) = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 (forall a. [(Text, Text)] -> String -> IO a -> IO a
withNixDaemonProxy (RunEffectParams -> [(Text, Text)]
runEffectExtraNixOptions RunEffectParams
p) String
socketPath, String
socketPath)
            else (forall a. a -> a
identity, String
"/nix/var/nix/daemon-socket/socket")

    forall {a}. IO a -> IO a
withNixDaemonProxyPerhaps forall a b. (a -> b) -> a -> b
$
      String -> Config -> IO ExitCode
Container.run
        String
runcDir
        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
"/etc", pathInHost :: Text
pathInHost = Text
etcDir, readOnly :: Bool
readOnly = Bool
False},
                BindMount {pathInContainer :: Text
pathInContainer = Text
"/secrets", pathInHost :: Text
pathInHost = Text
secretsDir, readOnly :: Bool
readOnly = Bool
True},
                -- 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},
                BindMount {pathInContainer :: Text
pathInContainer = Text
"/nix/var/nix/daemon-socket/socket", pathInHost :: Text
pathInHost = forall a b. ConvertText a b => a -> b
toS String
forwardedSocketPath, readOnly :: Bool
readOnly = Bool
True}
              ],
            executable :: Text
executable = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
drvBuilder,
            arguments :: [Text]
arguments = 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 forall k a. Ord k => Map k a -> Map k a -> Map k a
// Map Text Text
drvEnv' forall k a. Ord k => Map k a -> Map k a -> Map k a
// Map Text Text
onlyImpureOverridableEnv forall k a. Ord k => Map k a -> Map k a -> Map k a
// Map Text Text
impureEnvVars 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
False
          }

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 <- forall r. Socket -> (ProtocolNumber -> IO r) -> IO r
withFdSocket Socket
sock \ProtocolNumber
fd -> do
    Fd
fd' <- Fd -> IO Fd
dup (forall a b. (Integral a, Num b) => a -> b
fromIntegral ProtocolNumber
fd)
    Fd -> IO Handle
fdToHandle Fd
fd'

  String
exe <- forall (m :: * -> *). MonadIO m => m String
WorkerProcess.getDaemonExe
  let opts :: [String]
opts = [(Text, Text)]
extraNixOptions forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Text
k, Text
v) -> [String
"--option", forall a b. ConvertText a b => a -> b
toS Text
k, 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
          }
  forall (m :: * -> *) a.
MonadUnliftIO m =>
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> m a)
-> m a
withCreateProcess CreateProcess
procSpec forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_in Maybe Handle
_out Maybe Handle
_err ProcessHandle
_processHandle -> do
    IO a
wrappedAction