{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeFamilies #-}
module Hercules.Agent.NixFile
(
HomeSchema,
HerculesCISchema,
OnPushSchema,
OnScheduleSchema,
ExtraInputsSchema,
InputDeclSchema,
InputsSchema,
InputSchema,
OutputsSchema,
TimeConstraintsSchema,
findNixFile,
loadNixFile,
HomeExpr (..),
homeExprRawValue,
getHerculesCI,
loadDefaultHerculesCI,
getVirtualValueByPath,
parseExtraInputs,
)
where
import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)
import Data.Map qualified as M
import Hercules.API.Agent.Evaluate.EvaluateEvent.InputDeclaration (InputDeclaration (SiblingInput), SiblingInput (MkSiblingInput))
import Hercules.API.Agent.Evaluate.EvaluateEvent.InputDeclaration qualified
import Hercules.Agent.NixFile.CiNixArgs (CiNixArgs (CiNixArgs))
import Hercules.Agent.NixFile.CiNixArgs qualified
import Hercules.Agent.NixFile.GitSource (GitSource)
import Hercules.Agent.NixFile.HerculesCIArgs (HerculesCIArgs)
import Hercules.Agent.NixFile.HerculesCIArgs qualified as HerculesCIArgs
import Hercules.CNix.Expr
( EvalState,
Match (IsAttrs),
NixAttrs,
Value (Value, rtValue),
addAllowedPath,
assertType,
autoCallFunction,
evalFile,
getAttr,
getFlakeFromFlakeRef,
getLocalFlake,
match',
toRawValue,
unsafeAssertType,
valueFromExpressionString,
)
import Hercules.CNix.Expr.Raw (RawValue)
import Hercules.CNix.Expr.Schema (Attrs, Dictionary, MonadEval, PSObject (PSObject), Provenance (Other), StringWithoutContext, basicAttrsWithProvenance, dictionaryToMap, fromPSObject, toPSObject, (#.), (#?), ($?), (.$), (>>$.), type (->.), type (->?), type (.), type (::.), type (::?), type (::??), type (?), type (|.))
import Hercules.CNix.Expr.Schema qualified as Schema
import Hercules.Error (escalateAs)
import Paths_hercules_ci_agent (getDataFileName)
import Protolude hiding (evalState)
import System.Directory qualified as Dir
import System.FilePath (takeDirectory, takeFileName, (</>))
import UnliftIO.Directory (doesPathExist)
type Ambiguity = [FilePath]
searchPath :: [Ambiguity]
searchPath :: [Ambiguity]
searchPath = [[FilePath
"nix/ci.nix", FilePath
"ci.nix"], [FilePath
"flake.nix"], [FilePath
"default.nix"]]
findNixFile :: FilePath -> IO (Either Text FilePath)
findNixFile :: FilePath -> IO (Either Text FilePath)
findNixFile FilePath
projectDir = do
[[Maybe (FilePath, FilePath)]]
searchResult <-
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Ambiguity]
searchPath forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ \FilePath
relPath ->
let path :: FilePath
path = FilePath
projectDir FilePath -> FilePath -> FilePath
</> FilePath
relPath
in FilePath -> IO Bool
Dir.doesFileExist FilePath
path forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (FilePath
relPath, FilePath
path)
Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a. [Maybe a] -> [a]
catMaybes [[Maybe (FilePath, FilePath)]]
searchResult of
[(FilePath
_relPath, FilePath
unambiguous)] : [[(FilePath, FilePath)]]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
unambiguous
[(FilePath, FilePath)]
ambiguous : [[(FilePath, FilePath)]]
_ ->
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
Text
"Don't know what to do, expecting only one of "
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Schema.englishOr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall a b. ConvertText a b => a -> b
toS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(FilePath, FilePath)]
ambiguous)
[] ->
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
Text
"Please provide a Nix expression to build. Could not find any of "
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Schema.englishOr (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. ConvertText a b => a -> b
toS) [Ambiguity]
searchPath)
forall a. Semigroup a => a -> a -> a
<> Text
" in your source"
data HomeExpr
= Flake (Value NixAttrs)
| CiNix FilePath RawValue
homeExprRawValue :: HomeExpr -> RawValue
homeExprRawValue :: HomeExpr -> RawValue
homeExprRawValue (Flake (Value RawValue
r)) = RawValue
r
homeExprRawValue (CiNix FilePath
_ RawValue
r) = RawValue
r
loadNixFile :: Ptr EvalState -> FilePath -> GitSource -> IO (Either Text HomeExpr)
loadNixFile :: Ptr EvalState -> FilePath -> GitSource -> IO (Either Text HomeExpr)
loadNixFile Ptr EvalState
evalState FilePath
projectPath GitSource
src = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
FilePath
nixFile <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Either Text FilePath)
findNixFile FilePath
projectPath
if FilePath -> FilePath
takeFileName FilePath
nixFile forall a. Eq a => a -> a -> Bool
== FilePath
"flake.nix"
then do
Bool
isGit <- forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesPathExist (FilePath -> FilePath
takeDirectory FilePath
nixFile FilePath -> FilePath -> FilePath
</> FilePath
".git")
Value NixAttrs
val <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
( if Bool
isGit
then Ptr EvalState -> ByteString -> IO RawValue
getFlakeFromFlakeRef Ptr EvalState
evalState (ByteString
"git+file://" forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
encodeUtf8 (forall a b. ConvertText a b => a -> b
toS FilePath
projectPath))
else Ptr EvalState -> Text -> IO RawValue
getLocalFlake Ptr EvalState
evalState (forall a b. ConvertText a b => a -> b
toS FilePath
projectPath)
)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) t.
(HasCallStack, MonadIO m, CheckType t) =>
Ptr EvalState -> RawValue -> m (Value t)
assertType Ptr EvalState
evalState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value NixAttrs -> HomeExpr
Flake Value NixAttrs
val)
else do
RawValue
rootValueOrFunction <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Ptr EvalState -> FilePath -> IO RawValue
evalFile Ptr EvalState
evalState FilePath
nixFile
Value NixAttrs
args <- forall a. RawValue -> Value a
unsafeAssertType @NixAttrs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. ToRawValue a => Ptr EvalState -> a -> IO RawValue
toRawValue Ptr EvalState
evalState CiNixArgs {src :: GitSource
src = GitSource
src})
RawValue
homeExpr <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Ptr EvalState -> RawValue -> Value NixAttrs -> IO RawValue
autoCallFunction Ptr EvalState
evalState RawValue
rootValueOrFunction Value NixAttrs
args
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> RawValue -> HomeExpr
CiNix FilePath
nixFile RawValue
homeExpr)
getHomeExprObject :: MonadEval m => HomeExpr -> m (PSObject HomeSchema)
getHomeExprObject :: forall (m :: * -> *).
MonadEval m =>
HomeExpr -> m (PSObject HomeSchema)
getHomeExprObject (Flake Value NixAttrs
attrs) = forall (f :: * -> *) a. Applicative f => a -> f a
pure PSObject {value :: RawValue
value = forall a. Value a -> RawValue
rtValue Value NixAttrs
attrs, provenance :: Provenance
provenance = FilePath -> Provenance
Schema.File FilePath
"flake.nix"}
getHomeExprObject (CiNix FilePath
f RawValue
obj) = forall (f :: * -> *) a. Applicative f => a -> f a
pure PSObject {value :: RawValue
value = RawValue
obj, provenance :: Provenance
provenance = FilePath -> Provenance
Schema.File FilePath
f}
type HomeSchema = Attrs '["herculesCI" ::? Attrs '[] ->? HerculesCISchema]
type HerculesCISchema =
Attrs
'[ "onPush" ::? Dictionary OnPushSchema,
"onSchedule" ::? Dictionary OnScheduleSchema
]
type OnPushSchema =
Attrs
'[ "extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction,
"enable" ::? Bool
]
type OutputsFunction = InputsSchema ->? OutputsSchema
type = Dictionary InputDeclSchema
type InputDeclSchema =
Attrs
'[ "project" ::. StringWithoutContext,
"ref" ::? StringWithoutContext
]
type OnScheduleSchema =
Attrs
'[ "extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction,
"enable" ::? Bool,
"when" ::?? TimeConstraintsSchema
]
type TimeConstraintsSchema =
Attrs
'[ "hour" ::?? HoursSchema,
"minute" ::?? MinuteSchema,
"dayOfWeek" ::?? DaysOfWeekSchema,
"dayOfMonth" ::?? DaysOfMonthSchema
]
type = Int64 |. [Int64]
type MinuteSchema = Int64
type DaysOfWeekSchema = [StringWithoutContext]
type DaysOfMonthSchema = [Int64]
type InputsSchema = Dictionary InputSchema
type InputSchema = Dictionary RawValue
type OutputsSchema = Dictionary RawValue
type DefaultHerculesCIHelperSchema =
Attrs
'[ "addDefaults" ::. Attrs '[] ->. Attrs '[] ->. HerculesCISchema
]
exprString :: forall a m. MonadEval m => ByteString -> m (PSObject a)
exprString :: forall a (m :: * -> *). MonadEval m => ByteString -> m (PSObject a)
exprString ByteString
bs = do
Ptr EvalState
evalState <- forall r (m :: * -> *). MonadReader r m => m r
ask
RawValue
value <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Ptr EvalState -> ByteString -> ByteString -> IO RawValue
valueFromExpressionString Ptr EvalState
evalState ByteString
bs ByteString
"/var/lib/empty/hercules-ci-agent-builtin"
forall (f :: * -> *) a. Applicative f => a -> f a
pure PSObject {value :: RawValue
value = RawValue
value, provenance :: Provenance
provenance = Text -> Provenance
Schema.Other Text
"hercules-ci-agent built-in expression"}
getHerculesCI :: MonadEval m => HomeExpr -> HerculesCIArgs -> m (Maybe (PSObject HerculesCISchema))
getHerculesCI :: forall (m :: * -> *).
MonadEval m =>
HomeExpr -> HerculesCIArgs -> m (Maybe (PSObject HerculesCISchema))
getHerculesCI HomeExpr
homeExpr HerculesCIArgs
args = do
PSObject HomeSchema
home <- forall (m :: * -> *).
MonadEval m =>
HomeExpr -> m (PSObject HomeSchema)
getHomeExprObject HomeExpr
homeExpr
PSObject (Attrs '[])
args' <- forall a b. PSObject a -> PSObject b
Schema.uncheckedCast forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(MonadEval m, ToRawValue a) =>
a -> m (PSObject (NixTypeFor a))
toPSObject HerculesCIArgs
args
case HomeExpr
homeExpr of
CiNix {} ->
PSObject HomeSchema
home forall {k} (s :: Symbol) (m :: * -> *) (as :: [Attr]) (w :: k).
(KnownSymbol s, MonadEval m) =>
PSObject (Attrs' as w)
-> AttrLabel s -> m (Maybe (PSObject (as ? s)))
#? forall a. IsLabel "herculesCI" a => a
#herculesCI
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse @Maybe \PSObject (Attrs '[] ->? HerculesCISchema)
herculesCI ->
PSObject (Attrs '[] ->? HerculesCISchema)
herculesCI forall (m :: * -> *) b a.
(MonadEval m, PossibleTypesForSchema b) =>
PSObject (a ->? b) -> PSObject a -> m (PSObject b)
$? PSObject (Attrs '[])
args'
Flake Value NixAttrs
flake ->
forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
PSObject (Attrs '[])
args'' <-
forall a (m :: * -> *). MonadEval m => ByteString -> m (PSObject a)
exprString @(Attrs _ ->. HomeSchema ->. Attrs _)
ByteString
"args': flake: args' // { primaryRepo = args'.primaryRepo // { outPath = flake.outPath; }; }"
forall (m :: * -> *) a b.
MonadEval m =>
m (PSObject (a ->. b)) -> m (PSObject a) -> m (PSObject b)
>>$. forall (f :: * -> *) a. Applicative f => a -> f a
pure PSObject (Attrs '[])
args'
forall (m :: * -> *) a b.
MonadEval m =>
m (PSObject (a ->. b)) -> m (PSObject a) -> m (PSObject b)
>>$. forall (f :: * -> *) a. Applicative f => a -> f a
pure PSObject HomeSchema
home
PSObject DefaultHerculesCIHelperSchema
dh <- forall (m :: * -> *).
MonadEval m =>
m (PSObject DefaultHerculesCIHelperSchema)
loadDefaultHerculesCI
PSObject (Attrs '[] ->. (Attrs '[] ->. HerculesCISchema))
fn <- PSObject DefaultHerculesCIHelperSchema
dh forall {k} (s :: Symbol) (m :: * -> *) (as :: [Attr]) (w :: k).
(KnownSymbol s, MonadEval m) =>
PSObject (Attrs' as w) -> AttrLabel s -> m (PSObject (as . s))
#. forall a. IsLabel "addDefaults" a => a
#addDefaults
let flakeObj :: PSObject (Attrs '[])
flakeObj = Value NixAttrs -> Provenance -> PSObject (Attrs '[])
basicAttrsWithProvenance Value NixAttrs
flake forall a b. (a -> b) -> a -> b
$ Text -> Provenance
Schema.Other Text
"your flake"
PSObject HerculesCISchema
hci <- PSObject (Attrs '[] ->. (Attrs '[] ->. HerculesCISchema))
fn forall (m :: * -> *) a b.
MonadIO m =>
PSObject (a ->. b) -> PSObject a -> m (PSObject b)
.$ PSObject (Attrs '[])
flakeObj forall (m :: * -> *) a b.
MonadEval m =>
m (PSObject (a ->. b)) -> m (PSObject a) -> m (PSObject b)
>>$. forall (f :: * -> *) a. Applicative f => a -> f a
pure PSObject (Attrs '[])
args''
forall (f :: * -> *) a. Applicative f => a -> f a
pure PSObject HerculesCISchema
hci {provenance :: Provenance
Schema.provenance = Text -> Provenance
Other Text
"the herculesCI attribute of your flake (after adding defaults)"}
parseExtraInputs :: MonadEval m => PSObject ExtraInputsSchema -> m (Map ByteString InputDeclaration)
PSObject ExtraInputsSchema
eis = forall (m :: * -> *) w.
MonadEval m =>
PSObject (Dictionary w) -> m (Map ByteString (PSObject w))
dictionaryToMap PSObject ExtraInputsSchema
eis forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
MonadEval m =>
PSObject InputDeclSchema -> m InputDeclaration
parseInputDecl
parseInputDecl :: MonadEval m => PSObject InputDeclSchema -> m InputDeclaration
parseInputDecl :: forall (m :: * -> *).
MonadEval m =>
PSObject InputDeclSchema -> m InputDeclaration
parseInputDecl PSObject InputDeclSchema
d = do
Text
project <- PSObject InputDeclSchema
d forall {k} (s :: Symbol) (m :: * -> *) (as :: [Attr]) (w :: k).
(KnownSymbol s, MonadEval m) =>
PSObject (Attrs' as w) -> AttrLabel s -> m (PSObject (as . s))
#. forall a. IsLabel "project" a => a
#project forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall schema a (m :: * -> *).
(FromPSObject schema a, MonadEval m) =>
PSObject schema -> m a
fromPSObject
Maybe Text
ref <- PSObject InputDeclSchema
d forall {k} (s :: Symbol) (m :: * -> *) (as :: [Attr]) (w :: k).
(KnownSymbol s, MonadEval m) =>
PSObject (Attrs' as w)
-> AttrLabel s -> m (Maybe (PSObject (as ? s)))
#? forall a. IsLabel "ref" a => a
#ref forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall schema a (m :: * -> *).
(FromPSObject schema a, MonadEval m) =>
PSObject schema -> m a
fromPSObject
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SiblingInput -> InputDeclaration
SiblingInput forall a b. (a -> b) -> a -> b
$ MkSiblingInput {project :: Text
project = Text
project, ref :: Maybe Text
ref = Maybe Text
ref}
getVirtualValueByPath ::
Ptr EvalState ->
FilePath ->
HerculesCIArgs ->
(Map ByteString InputDeclaration -> IO (Value NixAttrs)) ->
[ByteString] ->
IO (Maybe RawValue)
getVirtualValueByPath :: Ptr EvalState
-> FilePath
-> HerculesCIArgs
-> (Map ByteString InputDeclaration -> IO (Value NixAttrs))
-> [ByteString]
-> IO (Maybe RawValue)
getVirtualValueByPath Ptr EvalState
evalState FilePath
filePath HerculesCIArgs
args Map ByteString InputDeclaration -> IO (Value NixAttrs)
resolveInputs [ByteString]
attrPath = do
HomeExpr
homeExpr <- forall exc (m :: * -> *) l a.
(Exception exc, MonadThrow m) =>
(l -> exc) -> Either l a -> m a
escalateAs Text -> FatalError
FatalError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr EvalState -> FilePath -> GitSource -> IO (Either Text HomeExpr)
loadNixFile Ptr EvalState
evalState FilePath
filePath (HerculesCIArgs -> GitSource
HerculesCIArgs.primaryRepo HerculesCIArgs
args)
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Ptr EvalState
evalState do
Maybe (PSObject HerculesCISchema)
herculesCI <- forall (m :: * -> *).
MonadEval m =>
HomeExpr -> HerculesCIArgs -> m (Maybe (PSObject HerculesCISchema))
getHerculesCI HomeExpr
homeExpr HerculesCIArgs
args
Maybe
(PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool])))
onPushMaybe <- forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe (PSObject HerculesCISchema)
herculesCI \PSObject HerculesCISchema
hci -> PSObject HerculesCISchema
hci forall {k} (s :: Symbol) (m :: * -> *) (as :: [Attr]) (w :: k).
(KnownSymbol s, MonadEval m) =>
PSObject (Attrs' as w)
-> AttrLabel s -> m (Maybe (PSObject (as ? s)))
#? forall a. IsLabel "onPush" a => a
#onPush
Maybe
(PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool,
"when" ::?? TimeConstraintsSchema])))
onScheduleMaybe <- forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe (PSObject HerculesCISchema)
herculesCI \PSObject HerculesCISchema
hci -> PSObject HerculesCISchema
hci forall {k} (s :: Symbol) (m :: * -> *) (as :: [Attr]) (w :: k).
(KnownSymbol s, MonadEval m) =>
PSObject (Attrs' as w)
-> AttrLabel s -> m (Maybe (PSObject (as ? s)))
#? forall a. IsLabel "onSchedule" a => a
#onSchedule
let require :: Maybe a -> MaybeT (ReaderT (Ptr EvalState) IO) a
require = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
m2s :: k -> Maybe a -> Map k a
m2s k
k (Just a
a) = forall k a. k -> a -> Map k a
M.singleton k
k a
a
m2s k
_ Maybe a
Nothing = forall a. Monoid a => a
mempty
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
case [ByteString]
attrPath of
[] | forall a. Maybe a -> Bool
isJust Maybe
(PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool])))
onPushMaybe Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe
(PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool,
"when" ::?? TimeConstraintsSchema])))
onScheduleMaybe -> do
Maybe RawValue
onPush' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToRawValue a => Ptr EvalState -> a -> IO RawValue
toRawValue Ptr EvalState
evalState) Maybe
(PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool])))
onPushMaybe
Maybe RawValue
onSchedule' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToRawValue a => Ptr EvalState -> a -> IO RawValue
toRawValue Ptr EvalState
evalState) Maybe
(PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool,
"when" ::?? TimeConstraintsSchema])))
onScheduleMaybe
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. ToRawValue a => Ptr EvalState -> a -> IO RawValue
toRawValue Ptr EvalState
evalState (forall {k} {a}. Ord k => k -> Maybe a -> Map k a
m2s (ByteString
"onPush" :: ByteString) Maybe RawValue
onPush' forall a. Semigroup a => a -> a -> a
<> forall {k} {a}. Ord k => k -> Maybe a -> Map k a
m2s ByteString
"onSchedule" Maybe RawValue
onSchedule')
ByteString
"onPush" : [] -> do
forall a. PSObject a -> RawValue
Schema.value forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. Maybe a -> MaybeT (ReaderT (Ptr EvalState) IO) a
require Maybe
(PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool])))
onPushMaybe
ByteString
"onPush" : ByteString
jobName : [ByteString]
attrPath' -> do
PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool]))
onPush <- forall {a}. Maybe a -> MaybeT (ReaderT (Ptr EvalState) IO) a
require Maybe
(PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool])))
onPushMaybe
PSObject
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool])
job <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (as :: [Attr]) w.
MonadEval m =>
ByteString -> PSObject (Attrs' as w) -> m (Maybe (PSObject w))
Schema.lookupDictBS ByteString
jobName PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool]))
onPush
PSObject OutputsSchema
outputs <- forall (m :: * -> *) (a :: [Attr]).
(MonadEval m, (a . "outputs") ~ OutputsFunction,
(a ? "extraInputs") ~ ExtraInputsSchema) =>
PSObject (Attrs a)
-> (Map ByteString InputDeclaration -> m (Value NixAttrs))
-> m (PSObject OutputsSchema)
resolveAndInvokeOutputs PSObject
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool])
job (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ByteString InputDeclaration -> IO (Value NixAttrs)
resolveInputs)
Value NixAttrs
outputAttrs <- forall schema (m :: * -> *).
(CheckType (NixTypeForSchema schema),
HasRawValueType (NixTypeForSchema schema), MonadEval m) =>
PSObject schema -> m (Value (NixTypeForSchema schema))
Schema.check PSObject OutputsSchema
outputs
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Ptr EvalState -> RawValue -> [ByteString] -> IO (Maybe RawValue)
attrByPath Ptr EvalState
evalState (forall a. Value a -> RawValue
rtValue Value NixAttrs
outputAttrs) [ByteString]
attrPath'
ByteString
"onSchedule" : [] -> do
forall a. PSObject a -> RawValue
Schema.value forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. Maybe a -> MaybeT (ReaderT (Ptr EvalState) IO) a
require Maybe
(PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool,
"when" ::?? TimeConstraintsSchema])))
onScheduleMaybe
ByteString
"onSchedule" : ByteString
jobName : [ByteString]
attrPath' -> do
PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool,
"when" ::?? TimeConstraintsSchema]))
onSchedule <- forall {a}. Maybe a -> MaybeT (ReaderT (Ptr EvalState) IO) a
require Maybe
(PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool,
"when" ::?? TimeConstraintsSchema])))
onScheduleMaybe
PSObject
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool,
"when" ::?? TimeConstraintsSchema])
job <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (as :: [Attr]) w.
MonadEval m =>
ByteString -> PSObject (Attrs' as w) -> m (Maybe (PSObject w))
Schema.lookupDictBS ByteString
jobName PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool,
"when" ::?? TimeConstraintsSchema]))
onSchedule
PSObject OutputsSchema
outputs <- forall (m :: * -> *) (a :: [Attr]).
(MonadEval m, (a . "outputs") ~ OutputsFunction,
(a ? "extraInputs") ~ ExtraInputsSchema) =>
PSObject (Attrs a)
-> (Map ByteString InputDeclaration -> m (Value NixAttrs))
-> m (PSObject OutputsSchema)
resolveAndInvokeOutputs PSObject
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool,
"when" ::?? TimeConstraintsSchema])
job (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ByteString InputDeclaration -> IO (Value NixAttrs)
resolveInputs)
Value NixAttrs
outputAttrs <- forall schema (m :: * -> *).
(CheckType (NixTypeForSchema schema),
HasRawValueType (NixTypeForSchema schema), MonadEval m) =>
PSObject schema -> m (Value (NixTypeForSchema schema))
Schema.check PSObject OutputsSchema
outputs
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Ptr EvalState -> RawValue -> [ByteString] -> IO (Maybe RawValue)
attrByPath Ptr EvalState
evalState (forall a. Value a -> RawValue
rtValue Value NixAttrs
outputAttrs) [ByteString]
attrPath'
[ByteString]
_ ->
case Maybe
(PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool])))
onPushMaybe of
Just PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool]))
jobs -> do
case [ByteString]
attrPath of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. PSObject a -> RawValue
Schema.value PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool]))
jobs
(ByteString
jobName : [ByteString]
attrPath') -> do
forall (m :: * -> *) (as :: [Attr]) w.
MonadEval m =>
ByteString -> PSObject (Attrs' as w) -> m (Maybe (PSObject w))
Schema.lookupDictBS ByteString
jobName PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool]))
jobs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just PSObject
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool])
selectedJob -> do
PSObject OutputsSchema
outputs <- forall (m :: * -> *) (a :: [Attr]).
(MonadEval m, (a . "outputs") ~ OutputsFunction,
(a ? "extraInputs") ~ ExtraInputsSchema) =>
PSObject (Attrs a)
-> (Map ByteString InputDeclaration -> m (Value NixAttrs))
-> m (PSObject OutputsSchema)
resolveAndInvokeOutputs PSObject
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool])
selectedJob (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ByteString InputDeclaration -> IO (Value NixAttrs)
resolveInputs)
Value NixAttrs
outputAttrs <- forall schema (m :: * -> *).
(CheckType (NixTypeForSchema schema),
HasRawValueType (NixTypeForSchema schema), MonadEval m) =>
PSObject schema -> m (Value (NixTypeForSchema schema))
Schema.check PSObject OutputsSchema
outputs
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Ptr EvalState -> RawValue -> [ByteString] -> IO (Maybe RawValue)
attrByPath Ptr EvalState
evalState (forall a. Value a -> RawValue
rtValue Value NixAttrs
outputAttrs) [ByteString]
attrPath'
Maybe
(PSObject
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool]))
Nothing -> forall (f :: * -> *) a. Alternative f => f a
empty
Maybe
(PSObject
(Attrs'
'[]
(Attrs
'["extraInputs" ::? ExtraInputsSchema,
"outputs" ::. OutputsFunction, "enable" ::? Bool])))
Nothing -> do
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Ptr EvalState -> RawValue -> [ByteString] -> IO (Maybe RawValue)
attrByPath Ptr EvalState
evalState (HomeExpr -> RawValue
homeExprRawValue HomeExpr
homeExpr) [ByteString]
attrPath
resolveAndInvokeOutputs ::
( MonadEval m,
a . "outputs" ~ OutputsFunction,
a ? "extraInputs" ~ ExtraInputsSchema
) =>
PSObject (Attrs a) ->
(Map ByteString InputDeclaration -> m (Value NixAttrs)) ->
m (PSObject OutputsSchema)
resolveAndInvokeOutputs :: forall (m :: * -> *) (a :: [Attr]).
(MonadEval m, (a . "outputs") ~ OutputsFunction,
(a ? "extraInputs") ~ ExtraInputsSchema) =>
PSObject (Attrs a)
-> (Map ByteString InputDeclaration -> m (Value NixAttrs))
-> m (PSObject OutputsSchema)
resolveAndInvokeOutputs PSObject (Attrs a)
job Map ByteString InputDeclaration -> m (Value NixAttrs)
resolveInputs = do
Maybe (Map ByteString InputDeclaration)
inputs <- PSObject (Attrs a)
job forall {k} (s :: Symbol) (m :: * -> *) (as :: [Attr]) (w :: k).
(KnownSymbol s, MonadEval m) =>
PSObject (Attrs' as w)
-> AttrLabel s -> m (Maybe (PSObject (as ? s)))
#? forall a. IsLabel "extraInputs" a => a
#extraInputs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
MonadEval m =>
PSObject ExtraInputsSchema -> m (Map ByteString InputDeclaration)
parseExtraInputs
Value NixAttrs
resolved <- Map ByteString InputDeclaration -> m (Value NixAttrs)
resolveInputs (forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty Maybe (Map ByteString InputDeclaration)
inputs)
PSObject OutputsFunction
f <- PSObject (Attrs a)
job forall {k} (s :: Symbol) (m :: * -> *) (as :: [Attr]) (w :: k).
(KnownSymbol s, MonadEval m) =>
PSObject (Attrs' as w) -> AttrLabel s -> m (PSObject (as . s))
#. forall a. IsLabel "outputs" a => a
#outputs
PSObject OutputsFunction
f forall (m :: * -> *) b a.
(MonadEval m, PossibleTypesForSchema b) =>
PSObject (a ->? b) -> PSObject a -> m (PSObject b)
$? (PSObject {provenance :: Provenance
provenance = Provenance
Schema.Data, value :: RawValue
value = forall a. Value a -> RawValue
rtValue Value NixAttrs
resolved})
attrByPath :: Ptr EvalState -> RawValue -> [ByteString] -> IO (Maybe RawValue)
attrByPath :: Ptr EvalState -> RawValue -> [ByteString] -> IO (Maybe RawValue)
attrByPath Ptr EvalState
_ RawValue
v [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just RawValue
v)
attrByPath Ptr EvalState
evalState RawValue
v (ByteString
a : [ByteString]
as) = do
Ptr EvalState -> RawValue -> IO Match
match' Ptr EvalState
evalState RawValue
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
IsAttrs Value NixAttrs
attrs ->
Ptr EvalState
-> Value NixAttrs -> ByteString -> IO (Maybe RawValue)
getAttr Ptr EvalState
evalState Value NixAttrs
attrs ByteString
a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\RawValue
attrValue -> Ptr EvalState -> RawValue -> [ByteString] -> IO (Maybe RawValue)
attrByPath Ptr EvalState
evalState RawValue
attrValue [ByteString]
as)
forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
Match
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
loadDefaultHerculesCI :: (MonadEval m) => m (PSObject DefaultHerculesCIHelperSchema)
loadDefaultHerculesCI :: forall (m :: * -> *).
MonadEval m =>
m (PSObject DefaultHerculesCIHelperSchema)
loadDefaultHerculesCI = do
FilePath
fname <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
getDataFileName FilePath
"data/default-herculesCI-for-flake.nix"
Ptr EvalState
evalState <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Ptr EvalState -> ByteString -> IO ()
addAllowedPath Ptr EvalState
evalState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ FilePath
fname
RawValue
v <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Ptr EvalState -> FilePath -> IO RawValue
evalFile Ptr EvalState
evalState FilePath
fname
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PSObject {value :: RawValue
value = RawValue
v, provenance :: Provenance
provenance = Text -> Provenance
Other Text
"<default herculesCI helper shim>"})