-- | This module contains the logic to resolve roles and include tasks
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

-- | Transform a 'PlaySyntax' into a resolved 'Play'
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}