-- | This module contains JSON decoder for the raw syntax.
module Haxible.Syntax
  ( decodeFile,
    JsonVars (..),
    BasePlay (..),
    BaseTask (..),
    TaskSyntax,
    PlaySyntax,
    propagableAttrs,
  )
where

import Data.Aeson
import Data.Aeson.Key qualified
import Data.Aeson.KeyMap qualified
import Data.ByteString (readFile)
import Data.Yaml qualified (decodeEither')
import Haxible.Prelude

data BasePlay task = BasePlay
  { forall task. BasePlay task -> [task]
tasks :: [task],
    -- | The list of attributes such as `become` or `gather_facts`.
    forall task. BasePlay task -> [(Text, Value)]
attrs :: [(Text, Value)]
  }
  deriving (BasePlay task -> BasePlay task -> Bool
(BasePlay task -> BasePlay task -> Bool)
-> (BasePlay task -> BasePlay task -> Bool) -> Eq (BasePlay task)
forall task. Eq task => BasePlay task -> BasePlay task -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BasePlay task -> BasePlay task -> Bool
$c/= :: forall task. Eq task => BasePlay task -> BasePlay task -> Bool
== :: BasePlay task -> BasePlay task -> Bool
$c== :: forall task. Eq task => BasePlay task -> BasePlay task -> Bool
Eq, Int -> BasePlay task -> ShowS
[BasePlay task] -> ShowS
BasePlay task -> String
(Int -> BasePlay task -> ShowS)
-> (BasePlay task -> String)
-> ([BasePlay task] -> ShowS)
-> Show (BasePlay task)
forall task. Show task => Int -> BasePlay task -> ShowS
forall task. Show task => [BasePlay task] -> ShowS
forall task. Show task => BasePlay task -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BasePlay task] -> ShowS
$cshowList :: forall task. Show task => [BasePlay task] -> ShowS
show :: BasePlay task -> String
$cshow :: forall task. Show task => BasePlay task -> String
showsPrec :: Int -> BasePlay task -> ShowS
$cshowsPrec :: forall task. Show task => Int -> BasePlay task -> ShowS
Show)

data BaseTask value = BaseTask
  { forall value. BaseTask value -> Maybe Text
name :: Maybe Text,
    forall value. BaseTask value -> Text
module_ :: Text,
    forall value. BaseTask value -> value
params :: value,
    -- | The list of attributes such as `register` or `loop`
    forall value. BaseTask value -> [(Text, Value)]
attrs :: [(Text, Value)]
  }
  deriving (BaseTask value -> BaseTask value -> Bool
(BaseTask value -> BaseTask value -> Bool)
-> (BaseTask value -> BaseTask value -> Bool)
-> Eq (BaseTask value)
forall value. Eq value => BaseTask value -> BaseTask value -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BaseTask value -> BaseTask value -> Bool
$c/= :: forall value. Eq value => BaseTask value -> BaseTask value -> Bool
== :: BaseTask value -> BaseTask value -> Bool
$c== :: forall value. Eq value => BaseTask value -> BaseTask value -> Bool
Eq, Int -> BaseTask value -> ShowS
[BaseTask value] -> ShowS
BaseTask value -> String
(Int -> BaseTask value -> ShowS)
-> (BaseTask value -> String)
-> ([BaseTask value] -> ShowS)
-> Show (BaseTask value)
forall value. Show value => Int -> BaseTask value -> ShowS
forall value. Show value => [BaseTask value] -> ShowS
forall value. Show value => BaseTask value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BaseTask value] -> ShowS
$cshowList :: forall value. Show value => [BaseTask value] -> ShowS
show :: BaseTask value -> String
$cshow :: forall value. Show value => BaseTask value -> String
showsPrec :: Int -> BaseTask value -> ShowS
$cshowsPrec :: forall value. Show value => Int -> BaseTask value -> ShowS
Show)

newtype Playbook = Playbook [PlaySyntax]
  deriving ((forall x. Playbook -> Rep Playbook x)
-> (forall x. Rep Playbook x -> Playbook) -> Generic Playbook
forall x. Rep Playbook x -> Playbook
forall x. Playbook -> Rep Playbook x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Playbook x -> Playbook
$cfrom :: forall x. Playbook -> Rep Playbook x
Generic, Playbook -> Playbook -> Bool
(Playbook -> Playbook -> Bool)
-> (Playbook -> Playbook -> Bool) -> Eq Playbook
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Playbook -> Playbook -> Bool
$c/= :: Playbook -> Playbook -> Bool
== :: Playbook -> Playbook -> Bool
$c== :: Playbook -> Playbook -> Bool
Eq, Int -> Playbook -> ShowS
[Playbook] -> ShowS
Playbook -> String
(Int -> Playbook -> ShowS)
-> (Playbook -> String) -> ([Playbook] -> ShowS) -> Show Playbook
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Playbook] -> ShowS
$cshowList :: [Playbook] -> ShowS
show :: Playbook -> String
$cshow :: Playbook -> String
showsPrec :: Int -> Playbook -> ShowS
$cshowsPrec :: Int -> Playbook -> ShowS
Show)
  deriving newtype (Value -> Parser [Playbook]
Value -> Parser Playbook
(Value -> Parser Playbook)
-> (Value -> Parser [Playbook]) -> FromJSON Playbook
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Playbook]
$cparseJSONList :: Value -> Parser [Playbook]
parseJSON :: Value -> Parser Playbook
$cparseJSON :: Value -> Parser Playbook
FromJSON)

newtype JsonVars = JsonVars [(Text, Value)]
  deriving (JsonVars -> JsonVars -> Bool
(JsonVars -> JsonVars -> Bool)
-> (JsonVars -> JsonVars -> Bool) -> Eq JsonVars
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JsonVars -> JsonVars -> Bool
$c/= :: JsonVars -> JsonVars -> Bool
== :: JsonVars -> JsonVars -> Bool
$c== :: JsonVars -> JsonVars -> Bool
Eq, Int -> JsonVars -> ShowS
[JsonVars] -> ShowS
JsonVars -> String
(Int -> JsonVars -> ShowS)
-> (JsonVars -> String) -> ([JsonVars] -> ShowS) -> Show JsonVars
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JsonVars] -> ShowS
$cshowList :: [JsonVars] -> ShowS
show :: JsonVars -> String
$cshow :: JsonVars -> String
showsPrec :: Int -> JsonVars -> ShowS
$cshowsPrec :: Int -> JsonVars -> ShowS
Show)

type TaskSyntax = BaseTask Value

type PlaySyntax = BasePlay TaskSyntax

items :: [Text] -> Data.Aeson.KeyMap.KeyMap Value -> [(Text, Value)]
items :: [Text] -> KeyMap Value -> [(Text, Value)]
items [Text]
xs = ((Text, Value) -> Bool) -> [(Text, Value)] -> [(Text, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Bool
isUnknown (Text -> Bool) -> ((Text, Value) -> Text) -> (Text, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Value) -> Text
forall a b. (a, b) -> a
fst) ([(Text, Value)] -> [(Text, Value)])
-> (KeyMap Value -> [(Text, Value)])
-> KeyMap Value
-> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, Value) -> (Text, Value))
-> [(Key, Value)] -> [(Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> Text) -> (Key, Value) -> (Text, Value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Key -> Text
Data.Aeson.Key.toText) ([(Key, Value)] -> [(Text, Value)])
-> (KeyMap Value -> [(Key, Value)])
-> KeyMap Value
-> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyMap Value -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
Data.Aeson.KeyMap.toList
  where
    isUnknown :: Text -> Bool
isUnknown Text
x = Text
x Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
xs

instance FromJSON JsonVars where
  parseJSON :: Value -> Parser JsonVars
parseJSON = String
-> (KeyMap Value -> Parser JsonVars) -> Value -> Parser JsonVars
forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
withObject String
"Vars" ((KeyMap Value -> Parser JsonVars) -> Value -> Parser JsonVars)
-> (KeyMap Value -> Parser JsonVars) -> Value -> Parser JsonVars
forall a b. (a -> b) -> a -> b
$ JsonVars -> Parser JsonVars
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsonVars -> Parser JsonVars)
-> (KeyMap Value -> JsonVars) -> KeyMap Value -> Parser JsonVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> JsonVars
JsonVars ([(Text, Value)] -> JsonVars)
-> (KeyMap Value -> [(Text, Value)]) -> KeyMap Value -> JsonVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> KeyMap Value -> [(Text, Value)]
items []

instance FromJSON PlaySyntax where
  parseJSON :: Value -> Parser PlaySyntax
parseJSON = String
-> (KeyMap Value -> Parser PlaySyntax)
-> Value
-> Parser PlaySyntax
forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
withObject String
"BasePlay" ((KeyMap Value -> Parser PlaySyntax) -> Value -> Parser PlaySyntax)
-> (KeyMap Value -> Parser PlaySyntax)
-> Value
-> Parser PlaySyntax
forall a b. (a -> b) -> a -> b
$ \KeyMap Value
v -> do
    [TaskSyntax]
pre_tasks <- KeyMap Value
v KeyMap Value -> Key -> Parser [TaskSyntax]
forall {a}. FromJSON a => KeyMap Value -> Key -> Parser [a]
`getList` Key
"pre_tasks"
    [TaskSyntax]
tasks <- KeyMap Value
v KeyMap Value -> Key -> Parser [TaskSyntax]
forall {a}. FromJSON a => KeyMap Value -> Key -> Parser [a]
`getList` Key
"tasks"
    [TaskSyntax]
roles <- (Text -> TaskSyntax) -> [Text] -> [TaskSyntax]
forall a b. (a -> b) -> [a] -> [b]
map Text -> TaskSyntax
mkRoleTask ([Text] -> [TaskSyntax]) -> Parser [Text] -> Parser [TaskSyntax]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (KeyMap Value
v KeyMap Value -> Key -> Parser [Text]
forall {a}. FromJSON a => KeyMap Value -> Key -> Parser [a]
`getList` Key
"roles")
    [TaskSyntax]
post_tasks <- KeyMap Value
v KeyMap Value -> Key -> Parser [TaskSyntax]
forall {a}. FromJSON a => KeyMap Value -> Key -> Parser [a]
`getList` Key
"post_tasks"
    PlaySyntax -> Parser PlaySyntax
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PlaySyntax -> Parser PlaySyntax)
-> PlaySyntax -> Parser PlaySyntax
forall a b. (a -> b) -> a -> b
$
      [TaskSyntax] -> [(Text, Value)] -> PlaySyntax
forall task. [task] -> [(Text, Value)] -> BasePlay task
BasePlay ([TaskSyntax]
pre_tasks [TaskSyntax] -> [TaskSyntax] -> [TaskSyntax]
forall a. Semigroup a => a -> a -> a
<> [TaskSyntax]
roles [TaskSyntax] -> [TaskSyntax] -> [TaskSyntax]
forall a. Semigroup a => a -> a -> a
<> [TaskSyntax]
tasks [TaskSyntax] -> [TaskSyntax] -> [TaskSyntax]
forall a. Semigroup a => a -> a -> a
<> [TaskSyntax]
post_tasks) ([Text] -> KeyMap Value -> [(Text, Value)]
items [Text]
nonPlayAttributes KeyMap Value
v)
    where
      getList :: KeyMap Value -> Key -> Parser [a]
getList KeyMap Value
v Key
k = [a] -> Maybe [a] -> [a]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [a] -> [a]) -> Parser (Maybe [a]) -> Parser [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyMap Value
v KeyMap Value -> Key -> Parser (Maybe [a])
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
k
      mkRoleTask :: Text -> TaskSyntax
mkRoleTask Text
name =
        BaseTask
          { $sel:name:BaseTask :: Maybe Text
name = Maybe Text
forall a. Maybe a
Nothing,
            $sel:module_:BaseTask :: Text
module_ = Text
"include_role",
            $sel:params:BaseTask :: Value
params = [(Text, Value)] -> Value
mkObj [(Text
"name", Text -> Value
String Text
name)],
            $sel:attrs:BaseTask :: [(Text, Value)]
attrs = []
          }
      nonPlayAttributes :: [Text]
nonPlayAttributes = [Text
"pre_tasks", Text
"tasks", Text
"post_tasks", Text
"roles"]

instance FromJSON TaskSyntax where
  parseJSON :: Value -> Parser TaskSyntax
parseJSON = String
-> (KeyMap Value -> Parser TaskSyntax)
-> Value
-> Parser TaskSyntax
forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
withObject String
"BaseTask" ((KeyMap Value -> Parser TaskSyntax) -> Value -> Parser TaskSyntax)
-> (KeyMap Value -> Parser TaskSyntax)
-> Value
-> Parser TaskSyntax
forall a b. (a -> b) -> a -> b
$ \KeyMap Value
v -> do
    (Text
module_, Value
params) <- case [Text] -> KeyMap Value -> [(Text, Value)]
items [Text]
nonModuleAttributes KeyMap Value
v of
      [(Text
n, Value
attr)] -> (Text, Value) -> Parser (Text, Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
n, Value
attr)
      [] -> String -> Parser (Text, Value)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Missing module"
      [(Text, Value)]
xs -> String -> Parser (Text, Value)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Text, Value)) -> String -> Parser (Text, Value)
forall a b. (a -> b) -> a -> b
$ String
"Can't pick module from: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a. Show a => a -> String
show (((Text, Value) -> Text) -> [(Text, Value)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Value) -> Text
forall a b. (a, b) -> a
fst [(Text, Value)]
xs)
    Maybe Text -> Text -> Value -> [(Text, Value)] -> TaskSyntax
forall value.
Maybe Text -> Text -> value -> [(Text, Value)] -> BaseTask value
BaseTask
      (Maybe Text -> Text -> Value -> [(Text, Value)] -> TaskSyntax)
-> Parser (Maybe Text)
-> Parser (Text -> Value -> [(Text, Value)] -> TaskSyntax)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyMap Value
v KeyMap Value -> Key -> Parser (Maybe Text)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"name"
      Parser (Text -> Value -> [(Text, Value)] -> TaskSyntax)
-> Parser Text -> Parser (Value -> [(Text, Value)] -> TaskSyntax)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
module_
      Parser (Value -> [(Text, Value)] -> TaskSyntax)
-> Parser Value -> Parser ([(Text, Value)] -> TaskSyntax)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
params
      Parser ([(Text, Value)] -> TaskSyntax)
-> Parser [(Text, Value)] -> Parser TaskSyntax
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(Text, Value)] -> Parser [(Text, Value)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> KeyMap Value -> [(Text, Value)]
items [Text
module_] KeyMap Value
v)
    where
      nonModuleAttributes :: [Text]
nonModuleAttributes = [Text
"name", Text
"register", Text
"loop", Text
"rescue", Text
"vars"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
propagableAttrs

propagableAttrs :: [Text]
propagableAttrs :: [Text]
propagableAttrs = [Text
"when", Text
"retries", Text
"delay", Text
"until", Text
"changed_when", Text
"failed_when", Text
"ignore_errors"]

decodeFile :: (Show a, FromJSON a, MonadIO m) => FilePath -> m a
decodeFile :: forall a (m :: * -> *).
(Show a, FromJSON a, MonadIO m) =>
String -> m a
decodeFile String
fp = do
  ByteString
bs <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
Data.ByteString.readFile String
fp)
  a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ case ByteString -> Either ParseException a
forall a. FromJSON a => ByteString -> Either ParseException a
Data.Yaml.decodeEither' ByteString
bs of
    Right a
v -> a
v
    Either ParseException a
x -> String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
fp String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": Unexpected YAML: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Either ParseException a -> String
forall a. Show a => a -> String
show Either ParseException a
x