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

module Hercules.Effect where

import Control.Monad.Catch (MonadThrow)
import qualified Data.Aeson as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
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 Text)
parseDrvSecretsMap :: Map ByteString ByteString -> Either Text (Map Text Text)
parseDrvSecretsMap Map ByteString ByteString
drvEnv =
  case Map ByteString ByteString
drvEnv Map ByteString ByteString
-> (Map ByteString ByteString -> Maybe ByteString)
-> Maybe ByteString
forall a b. a -> (a -> b) -> b
& ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ByteString
"secretsMap" of
    Maybe ByteString
Nothing -> Map Text Text -> Either Text (Map Text Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text Text
forall a. Monoid a => a
mempty
    Just ByteString
secretsMapText -> case ByteString -> Either String (Map Text Text)
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (ByteString -> ByteString
BL.fromStrict ByteString
secretsMapText) of
      Left String
_ -> Text -> Either Text (Map Text Text)
forall a b. a -> Either a b
Left Text
"Could not parse secretsMap variable in derivation. It must be a JSON dictionary of strings referencing agent secret names."
      Right Map Text Text
r -> Map Text Text -> Either Text (Map Text Text)
forall a b. b -> Either a b
Right Map Text Text
r

-- | Write secrets to file based on secretsMap value
writeSecrets :: (MonadIO m, KatipContext m) => Bool -> Maybe SecretContext -> Maybe FilePath -> Map Text Text -> Map Text (Sensitive Formats.Secret.Secret) -> FilePath -> m ()
writeSecrets :: forall (m :: * -> *).
(MonadIO m, KatipContext m) =>
Bool
-> Maybe SecretContext
-> Maybe String
-> Map Text Text
-> Map Text (Sensitive Secret)
-> String
-> m ()
writeSecrets Bool
friendly Maybe SecretContext
ctxMaybe Maybe String
sourceFileMaybe Map Text Text
secretsMap Map Text (Sensitive Secret)
extraSecrets 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 (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 (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 Text -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text Text
secretsMap
        then Map Text (Sensitive Secret) -> m (Map Text (Sensitive Secret))
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 (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 (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 Text
secretsMap Map Text Text
-> (Map Text Text -> m (Map Text (Sensitive Secret)))
-> m (Map Text (Sensitive Secret))
forall a b. a -> (a -> b) -> b
& (Text -> Text -> m (Sensitive Secret))
-> Map Text Text -> 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 (Text
secretName :: Text) -> do
            let gotoFail :: m a
gotoFail =
                  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
secretName 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 -> m (Sensitive Secret)
forall {a}. m a
gotoFail
              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 (f :: * -> *) a. Applicative f => a -> f a
pure (Secret -> Sensitive Secret) -> Secret -> Sensitive Secret
forall a b. (a -> b) -> a -> b
$
                        Secret :: Map Text Value -> Maybe Condition -> Secret
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 (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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure Sensitive Secret
r
                  (Bool
False, Maybe Condition
Nothing) -> m (Sensitive Secret)
forall {a}. m a
gotoFail
                  (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 (f :: * -> *) a. Applicative f => a -> f a
pure Sensitive Secret
r else m (Sensitive Secret)
forall {a}. m a
gotoFail

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 -> 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} = do
  ByteString
drvBuilder <- IO ByteString -> m ByteString
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 (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 (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 Text
drvSecretsMap <- (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)
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 String -> a
forall a b. ConvertText a b => a -> b
toS String
newDir a -> f () -> 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
runcDir <- String -> m String
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
          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 (f :: * -> *) a. Applicative f => a -> f a
pure (Secret -> Sensitive Secret) -> Secret -> Sensitive Secret
forall a b. (a -> b) -> a -> b
$
                    Secret :: Map Text Value -> Maybe Condition -> Secret
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 Text
-> Map Text (Sensitive Secret)
-> String
-> m ()
forall (m :: * -> *).
(MonadIO m, KatipContext m) =>
Bool
-> Maybe SecretContext
-> Maybe String
-> Map Text Text
-> Map Text (Sensitive Secret)
-> String
-> m ()
writeSecrets (RunEffectParams -> Bool
runEffectFriendly RunEffectParams
p) (RunEffectParams -> Maybe SecretContext
runEffectSecretContext RunEffectParams
p) Maybe String
secretsPath Map Text Text
drvSecretsMap Map Text (Sensitive Secret)
extraSecrets (Text -> String
forall a b. ConvertText a b => a -> b
toS Text
secretsDir)
  IO ExitCode -> m ExitCode
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 (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 (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 (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")
            ]
        (//) :: 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")

    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
runcDir
        Config :: [BindMount]
-> Text
-> [Text]
-> Map Text Text
-> Text
-> Text
-> Bool
-> Config
Container.Config
          { extraBindMounts :: [BindMount]
extraBindMounts =
              [ BindMount :: Text -> Text -> Bool -> BindMount
BindMount {pathInContainer :: Text
pathInContainer = Text
"/build", pathInHost :: Text
pathInHost = Text
buildDir, readOnly :: Bool
readOnly = Bool
False},
                BindMount :: Text -> Text -> Bool -> BindMount
BindMount {pathInContainer :: Text
pathInContainer = Text
"/etc", pathInHost :: Text
pathInHost = Text
etcDir, readOnly :: Bool
readOnly = Bool
False},
                BindMount :: Text -> Text -> Bool -> BindMount
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 :: Text -> Text -> Bool -> BindMount
BindMount {pathInContainer :: Text
pathInContainer = Text
"/etc/resolv.conf", pathInHost :: Text
pathInHost = Text
"/etc/resolv.conf", readOnly :: Bool
readOnly = Bool
False},
                BindMount :: Text -> Text -> Bool -> BindMount
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}
              ],
            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
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 <- 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 (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