module Haxible.Import
( resolveImport,
BasePlay (..),
BaseTask (..),
Play,
Task,
TaskValue (..),
RoleValue (..),
BlockValue (..),
)
where
import Haxible.Prelude
import Haxible.Syntax
type Importer a = ReaderT Env IO a
data Env = Env
{ Env -> FilePath
source :: FilePath,
Env -> [FilePath]
history :: [FilePath]
}
deriving (Env -> Env -> Bool
(Env -> Env -> Bool) -> (Env -> Env -> Bool) -> Eq Env
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Env -> Env -> Bool
$c/= :: Env -> Env -> Bool
== :: Env -> Env -> Bool
$c== :: Env -> Env -> Bool
Eq, Int -> Env -> ShowS
[Env] -> ShowS
Env -> FilePath
(Int -> Env -> ShowS)
-> (Env -> FilePath) -> ([Env] -> ShowS) -> Show Env
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Env] -> ShowS
$cshowList :: [Env] -> ShowS
show :: Env -> FilePath
$cshow :: Env -> FilePath
showsPrec :: Int -> Env -> ShowS
$cshowsPrec :: Int -> Env -> ShowS
Show)
type Play = BasePlay Task
type Task = BaseTask TaskValue
data TaskValue
= Module Value
| Role RoleValue
| Tasks Text [Task]
| Facts Vars
| CacheableFacts Value Vars
| Block BlockValue
deriving (TaskValue -> TaskValue -> Bool
(TaskValue -> TaskValue -> Bool)
-> (TaskValue -> TaskValue -> Bool) -> Eq TaskValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TaskValue -> TaskValue -> Bool
$c/= :: TaskValue -> TaskValue -> Bool
== :: TaskValue -> TaskValue -> Bool
$c== :: TaskValue -> TaskValue -> Bool
Eq, Int -> TaskValue -> ShowS
[TaskValue] -> ShowS
TaskValue -> FilePath
(Int -> TaskValue -> ShowS)
-> (TaskValue -> FilePath)
-> ([TaskValue] -> ShowS)
-> Show TaskValue
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TaskValue] -> ShowS
$cshowList :: [TaskValue] -> ShowS
show :: TaskValue -> FilePath
$cshow :: TaskValue -> FilePath
showsPrec :: Int -> TaskValue -> ShowS
$cshowsPrec :: Int -> TaskValue -> ShowS
Show)
data RoleValue = RoleValue
{ RoleValue -> [Task]
tasks :: [Task],
RoleValue -> [(Text, Value)]
defaults :: [(Text, Value)],
RoleValue -> Text
name :: Text
}
deriving (RoleValue -> RoleValue -> Bool
(RoleValue -> RoleValue -> Bool)
-> (RoleValue -> RoleValue -> Bool) -> Eq RoleValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RoleValue -> RoleValue -> Bool
$c/= :: RoleValue -> RoleValue -> Bool
== :: RoleValue -> RoleValue -> Bool
$c== :: RoleValue -> RoleValue -> Bool
Eq, Int -> RoleValue -> ShowS
[RoleValue] -> ShowS
RoleValue -> FilePath
(Int -> RoleValue -> ShowS)
-> (RoleValue -> FilePath)
-> ([RoleValue] -> ShowS)
-> Show RoleValue
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [RoleValue] -> ShowS
$cshowList :: [RoleValue] -> ShowS
show :: RoleValue -> FilePath
$cshow :: RoleValue -> FilePath
showsPrec :: Int -> RoleValue -> ShowS
$cshowsPrec :: Int -> RoleValue -> ShowS
Show)
data BlockValue = BlockValue
{ BlockValue -> [Task]
tasks :: [Task],
BlockValue -> [Task]
rescues :: [Task]
}
deriving (BlockValue -> BlockValue -> Bool
(BlockValue -> BlockValue -> Bool)
-> (BlockValue -> BlockValue -> Bool) -> Eq BlockValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockValue -> BlockValue -> Bool
$c/= :: BlockValue -> BlockValue -> Bool
== :: BlockValue -> BlockValue -> Bool
$c== :: BlockValue -> BlockValue -> Bool
Eq, Int -> BlockValue -> ShowS
[BlockValue] -> ShowS
BlockValue -> FilePath
(Int -> BlockValue -> ShowS)
-> (BlockValue -> FilePath)
-> ([BlockValue] -> ShowS)
-> Show BlockValue
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [BlockValue] -> ShowS
$cshowList :: [BlockValue] -> ShowS
show :: BlockValue -> FilePath
$cshow :: BlockValue -> FilePath
showsPrec :: Int -> BlockValue -> ShowS
$cshowsPrec :: Int -> BlockValue -> ShowS
Show)
resolveTask :: TaskSyntax -> Importer Task
resolveTask :: TaskSyntax -> Importer Task
resolveTask TaskSyntax
task = do
TaskValue
taskValue <- case TaskSyntax
task.module_ of
Text
"include_role" -> ReaderT Env IO TaskValue
includeRole
Text
"include_tasks" -> ReaderT Env IO TaskValue
includeTasks
Text
"set_fact" -> ReaderT Env IO TaskValue
setFact
Text
"block" -> ReaderT Env IO TaskValue
block
Text
"add_host" -> FilePath -> ReaderT Env IO TaskValue
forall a. HasCallStack => FilePath -> a
error FilePath
"add_host is not implemented"
Text
_ -> TaskValue -> ReaderT Env IO TaskValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TaskValue -> ReaderT Env IO TaskValue)
-> TaskValue -> ReaderT Env IO TaskValue
forall a b. (a -> b) -> a -> b
$ Value -> TaskValue
Module TaskSyntax
task.params
Task -> Importer Task
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Task -> Importer Task) -> Task -> Importer Task
forall a b. (a -> b) -> a -> b
$ TaskSyntax
task {$sel:params:BaseTask :: TaskValue
params = TaskValue
taskValue}
where
withFile :: FilePath -> (t -> m b) -> m b
withFile FilePath
fp t -> m b
go = do
[FilePath]
hist <- (Env -> [FilePath]) -> m [FilePath]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> [FilePath]
history
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
fp FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
hist) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
FilePath -> m ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Cyclic import detected: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> FilePath
show FilePath
fp FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" already in " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
hist
t
r <- FilePath -> m t
forall a (m :: * -> *).
(Show a, FromJSON a, MonadIO m) =>
FilePath -> m a
decodeFile FilePath
fp
(Env -> Env) -> m b -> m b
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Env -> Env -> Env
forall a b. a -> b -> a
const (Env -> Env -> Env) -> Env -> Env -> Env
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> Env
Env FilePath
fp (FilePath
fp FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
hist)) (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$ t -> m b
go t
r
getRolePath :: FilePath -> FilePath -> m FilePath
getRolePath FilePath
name FilePath
path = do
FilePath
source <- (Env -> FilePath) -> m FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> FilePath
source
FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> m FilePath) -> FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory FilePath
source FilePath -> ShowS
</> FilePath
"roles" FilePath -> ShowS
</> FilePath
name FilePath -> ShowS
</> FilePath
path
includeRole :: ReaderT Env IO TaskValue
includeRole = do
let role_name :: FilePath
role_name = Text -> FilePath
forall source target. From source target => source -> target
from (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"missing name" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Getting (First Text) Value Text -> Value -> Maybe Text
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"name" ((Value -> Const (First Text) Value)
-> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Text) Value Text
forall t. AsPrimitive t => Prism' t Text
_String) (Value -> Maybe Text) -> Value -> Maybe Text
forall a b. (a -> b) -> a -> b
$ TaskSyntax
task.params
name :: Text
name = FilePath -> Text
forall source target. From source target => source -> target
from FilePath
role_name
FilePath
role_path <- FilePath -> FilePath -> ReaderT Env IO FilePath
forall {m :: * -> *}.
MonadReader Env m =>
FilePath -> FilePath -> m FilePath
getRolePath FilePath
role_name (FilePath -> ReaderT Env IO FilePath)
-> FilePath -> ReaderT Env IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"tasks" FilePath -> ShowS
</> FilePath
"main.yaml"
FilePath
role_defaults <- FilePath -> FilePath -> ReaderT Env IO FilePath
forall {m :: * -> *}.
MonadReader Env m =>
FilePath -> FilePath -> m FilePath
getRolePath FilePath
role_name (FilePath -> ReaderT Env IO FilePath)
-> FilePath -> ReaderT Env IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"defaults" FilePath -> ShowS
</> FilePath
"main.yaml"
JsonVars [(Text, Value)]
defaults <- FilePath -> ReaderT Env IO JsonVars
forall a (m :: * -> *).
(Show a, FromJSON a, MonadIO m) =>
FilePath -> m a
decodeFile FilePath
role_defaults
FilePath
-> ([TaskSyntax] -> ReaderT Env IO TaskValue)
-> ReaderT Env IO TaskValue
forall {m :: * -> *} {t} {b}.
(MonadReader Env m, Show t, FromJSON t, MonadIO m) =>
FilePath -> (t -> m b) -> m b
withFile FilePath
role_path (([TaskSyntax] -> ReaderT Env IO TaskValue)
-> ReaderT Env IO TaskValue)
-> ([TaskSyntax] -> ReaderT Env IO TaskValue)
-> ReaderT Env IO TaskValue
forall a b. (a -> b) -> a -> b
$ \[TaskSyntax]
baseTasks -> do
[Task]
tasks <- (TaskSyntax -> Importer Task)
-> [TaskSyntax] -> ReaderT Env IO [Task]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TaskSyntax -> Importer Task
resolveTask [TaskSyntax]
baseTasks
TaskValue -> ReaderT Env IO TaskValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TaskValue -> ReaderT Env IO TaskValue)
-> TaskValue -> ReaderT Env IO TaskValue
forall a b. (a -> b) -> a -> b
$ RoleValue -> TaskValue
Role RoleValue {Text
name :: Text
$sel:name:RoleValue :: Text
name, [Task]
tasks :: [Task]
$sel:tasks:RoleValue :: [Task]
tasks, [(Text, Value)]
defaults :: [(Text, Value)]
$sel:defaults:RoleValue :: [(Text, Value)]
defaults}
includeTasks :: ReaderT Env IO TaskValue
includeTasks = do
FilePath
source <- (Env -> FilePath) -> ReaderT Env IO FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> FilePath
source
let task_name :: FilePath
task_name = Text -> FilePath
forall source target. From source target => source -> target
from (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"missing name" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Getting (First Text) Value Text -> Value -> Maybe Text
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First Text) Value Text
forall t. AsPrimitive t => Prism' t Text
_String (Value -> Maybe Text) -> Value -> Maybe Text
forall a b. (a -> b) -> a -> b
$ TaskSyntax
task.params
task_path :: FilePath
task_path = ShowS
takeDirectory FilePath
source FilePath -> ShowS
</> FilePath
task_name
FilePath
-> ([TaskSyntax] -> ReaderT Env IO TaskValue)
-> ReaderT Env IO TaskValue
forall {m :: * -> *} {t} {b}.
(MonadReader Env m, Show t, FromJSON t, MonadIO m) =>
FilePath -> (t -> m b) -> m b
withFile FilePath
task_path (([TaskSyntax] -> ReaderT Env IO TaskValue)
-> ReaderT Env IO TaskValue)
-> ([TaskSyntax] -> ReaderT Env IO TaskValue)
-> ReaderT Env IO TaskValue
forall a b. (a -> b) -> a -> b
$ \[TaskSyntax]
baseTasks -> do
Text -> [Task] -> TaskValue
Tasks (FilePath -> Text
forall source target. From source target => source -> target
from FilePath
task_name) ([Task] -> TaskValue)
-> ReaderT Env IO [Task] -> ReaderT Env IO TaskValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TaskSyntax -> Importer Task)
-> [TaskSyntax] -> ReaderT Env IO [Task]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TaskSyntax -> Importer Task
resolveTask [TaskSyntax]
baseTasks
block :: ReaderT Env IO TaskValue
block = do
[Task]
tasks <- Value -> ReaderT Env IO [Task]
resolveBlock TaskSyntax
task.params
[Task]
rescues <- Value -> ReaderT Env IO [Task]
resolveBlock (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Text -> [(Text, Value)] -> Maybe Value
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"rescue" TaskSyntax
task.attrs))
TaskValue -> ReaderT Env IO TaskValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TaskValue -> ReaderT Env IO TaskValue)
-> TaskValue -> ReaderT Env IO TaskValue
forall a b. (a -> b) -> a -> b
$ BlockValue -> TaskValue
Block BlockValue {[Task]
tasks :: [Task]
$sel:tasks:BlockValue :: [Task]
tasks, [Task]
rescues :: [Task]
$sel:rescues:BlockValue :: [Task]
rescues}
resolveBlock :: Value -> Importer [Task]
resolveBlock :: Value -> ReaderT Env IO [Task]
resolveBlock = \case
Value
Null -> [Task] -> ReaderT Env IO [Task]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Value
v -> (TaskSyntax -> Importer Task)
-> [TaskSyntax] -> ReaderT Env IO [Task]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TaskSyntax -> Importer Task
resolveTask ([TaskSyntax] -> ReaderT Env IO [Task])
-> (Value -> [TaskSyntax]) -> Value -> ReaderT Env IO [Task]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result [TaskSyntax] -> [TaskSyntax]
forall {a}. Result a -> a
unwrapJSON (Result [TaskSyntax] -> [TaskSyntax])
-> (Value -> Result [TaskSyntax]) -> Value -> [TaskSyntax]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Result [TaskSyntax]
forall a. FromJSON a => Value -> Result a
fromJSON (Value -> ReaderT Env IO [Task]) -> Value -> ReaderT Env IO [Task]
forall a b. (a -> b) -> a -> b
$ Value
v
unwrapJSON :: Result a -> a
unwrapJSON = \case
Error FilePath
e -> FilePath -> a
forall a. HasCallStack => FilePath -> a
error (FilePath -> a) -> FilePath -> a
forall a b. (a -> b) -> a -> b
$ FilePath
"Unexpected json: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
e
Success a
a -> a
a
setFact :: ReaderT Env IO TaskValue
setFact = do
let JsonVars [(Text, Value)]
vars = Result JsonVars -> JsonVars
forall {a}. Result a -> a
unwrapJSON (Result JsonVars -> JsonVars)
-> (Value -> Result JsonVars) -> Value -> JsonVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Result JsonVars
forall a. FromJSON a => Value -> Result a
fromJSON (Value -> JsonVars) -> Value -> JsonVars
forall a b. (a -> b) -> a -> b
$ TaskSyntax
task.params
TaskValue -> ReaderT Env IO TaskValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TaskValue -> ReaderT Env IO TaskValue)
-> TaskValue -> ReaderT Env IO TaskValue
forall a b. (a -> b) -> a -> b
$ case Text -> [(Text, Value)] -> Maybe Value
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"cacheable" [(Text, Value)]
vars of
Just Value
v -> Value -> [(Text, Value)] -> TaskValue
CacheableFacts Value
v (((Text, Value) -> Bool) -> [(Text, Value)] -> [(Text, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text, Value)
var -> (Text, Value) -> Text
forall a b. (a, b) -> a
fst (Text, Value)
var Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"cacheable") [(Text, Value)]
vars)
Maybe Value
Nothing -> [(Text, Value)] -> TaskValue
Facts [(Text, Value)]
vars
resolveImport :: FilePath -> PlaySyntax -> IO Play
resolveImport :: FilePath -> PlaySyntax -> IO Play
resolveImport FilePath
source (BasePlay [TaskSyntax]
baseTasks [(Text, Value)]
attrs) = do
[Task]
tasks <- ReaderT Env IO [Task] -> Env -> IO [Task]
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ((TaskSyntax -> Importer Task)
-> [TaskSyntax] -> ReaderT Env IO [Task]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TaskSyntax -> Importer Task
resolveTask [TaskSyntax]
baseTasks) (FilePath -> [FilePath] -> Env
Env FilePath
source [])
Play -> IO Play
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Play -> IO Play) -> Play -> IO Play
forall a b. (a -> b) -> a -> b
$ BasePlay {[Task]
$sel:tasks:BasePlay :: [Task]
tasks :: [Task]
tasks, [(Text, Value)]
$sel:attrs:BasePlay :: [(Text, Value)]
attrs :: [(Text, Value)]
attrs}