{-# 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" (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 (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 (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
_ -> 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. 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 =
  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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure (GitToken -> SecretRef
GitToken (GitToken -> SecretRef) -> GitToken -> SecretRef
forall a b. (a -> b) -> a -> b
$ MkGitToken :: GitToken
MkGitToken {})
        Text
_ -> Text -> Either Text SecretRef
forall a b. a -> Either a b
Left (Text -> Either Text SecretRef) -> Text -> Either Text SecretRef
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse secret reference " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", because the type is unknown; must be \"GitToken\"."
    Just Value
_ -> Text -> Either Text SecretRef
forall a b. a -> Either a b
Left (Text -> Either Text SecretRef) -> Text -> Either Text SecretRef
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse secret reference " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", because the type attribute is not a string."
    Maybe Value
Nothing -> Text -> Either Text SecretRef
forall a b. a -> Either a b
Left (Text -> Either Text SecretRef) -> Text -> Either Text SecretRef
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse secret reference " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", because it does not have a type attribute."
parseSecretRef Text
attrName Value
_ = Text -> Either Text SecretRef
forall a b. a -> Either a b
Left (Text -> Either Text SecretRef) -> Text -> Either Text SecretRef
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse secret reference " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", because it is neither a string nor an attribute set."

-- | Write secrets to file based on secretsMap value
writeSecrets ::
  (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 (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 SecretRef -> 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 (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 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 (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_ -> Secret :: Map Text Value -> Maybe Condition -> Secret
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 (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 (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 (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) -> 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 (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 -> Text
runEffectApiBaseURL :: Text,
    RunEffectParams -> String
runEffectDir :: FilePath,
    RunEffectParams -> Maybe (Id "project")
runEffectProjectId :: Maybe (Id "project"),
    RunEffectParams -> Maybe Text
runEffectProjectPath :: Maybe Text,
    RunEffectParams -> Bool
runEffectUseNixDaemonProxy :: Bool,
    RunEffectParams -> [(Text, Text)]
runEffectExtraNixOptions :: [(Text, Text)],
    -- | Whether we can relax security in favor of usability; 'True' in @hci effect run@. 'False' in agent.
    RunEffectParams -> Bool
runEffectFriendly :: Bool
  }

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

runEffect :: (MonadThrow m, KatipContext m) => RunEffectParams -> m ExitCode
runEffect :: forall (m :: * -> *).
(MonadThrow m, KatipContext m) =>
RunEffectParams -> m ExitCode
runEffect p :: RunEffectParams
p@RunEffectParams {runEffectDerivation :: RunEffectParams -> Derivation
runEffectDerivation = Derivation
derivation, runEffectSecretsConfigPath :: RunEffectParams -> Maybe String
runEffectSecretsConfigPath = Maybe String
secretsPath, runEffectApiBaseURL :: RunEffectParams -> Text
runEffectApiBaseURL = Text
apiBaseURL, runEffectDir :: RunEffectParams -> String
runEffectDir = String
dir, runEffectServerSecrets :: RunEffectParams -> Sensitive (Map Text (Map Text Value))
runEffectServerSecrets = Sensitive (Map Text (Map Text Value))
serverSecrets} = do
  ByteString
drvBuilder <- IO ByteString -> m ByteString
forall (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 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
  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 SecretRef
-> Map Text (Sensitive Secret)
-> Map Text (Sensitive (Map Text Value))
-> String
-> m ()
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 (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 (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