{-# LANGUAGE TupleSections #-}

--------------------------------------------------------------------
-- |
-- Module    : Text.Atom.Feed.Validate
-- Copyright : (c) Galois, Inc. 2008,
--             (c) Sigbjorn Finne 2009-
-- License   : BSD3
--
-- Maintainer: Sigbjorn Finne <sof@forkIO.com>
-- Stability : provisional
-- Portability: portable
--
--------------------------------------------------------------------
module Text.Atom.Feed.Validate
  ( VTree(..)
  , ValidatorResult
  , advice
  , demand
  , valid
  , mkTree
  , flattenT
  , validateEntry
  , checkEntryAuthor
  , checkCats
  , checkContents
  , checkContributor
  , checkContentLink
  , checkLinks
  , checkId
  , checkPublished
  , checkRights
  , checkSource
  , checkSummary
  , checkTitle
  , checkUpdated
  , checkCat
  , checkContent
  , checkTerm
  , checkAuthor
  , checkPerson
  , checkName
  , checkEmail
  , checkUri
  ) where

import Prelude.Compat

import Data.XML.Types
import Text.Atom.Feed.Import

import Data.List.Compat
import Data.Maybe

data VTree a
  = VNode [a] [VTree a]
  | VLeaf [a]
  deriving (VTree a -> VTree a -> Bool
(VTree a -> VTree a -> Bool)
-> (VTree a -> VTree a -> Bool) -> Eq (VTree a)
forall a. Eq a => VTree a -> VTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VTree a -> VTree a -> Bool
$c/= :: forall a. Eq a => VTree a -> VTree a -> Bool
== :: VTree a -> VTree a -> Bool
$c== :: forall a. Eq a => VTree a -> VTree a -> Bool
Eq, Int -> VTree a -> ShowS
[VTree a] -> ShowS
VTree a -> String
(Int -> VTree a -> ShowS)
-> (VTree a -> String) -> ([VTree a] -> ShowS) -> Show (VTree a)
forall a. Show a => Int -> VTree a -> ShowS
forall a. Show a => [VTree a] -> ShowS
forall a. Show a => VTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VTree a] -> ShowS
$cshowList :: forall a. Show a => [VTree a] -> ShowS
show :: VTree a -> String
$cshow :: forall a. Show a => VTree a -> String
showsPrec :: Int -> VTree a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> VTree a -> ShowS
Show)

type ValidatorResult = VTree (Bool, String)

advice :: String -> ValidatorResult
advice :: String -> ValidatorResult
advice String
s = [(Bool, String)] -> ValidatorResult
forall a. [a] -> VTree a
VLeaf [(Bool
False, String
s)]

demand :: String -> ValidatorResult
demand :: String -> ValidatorResult
demand String
s = [(Bool, String)] -> ValidatorResult
forall a. [a] -> VTree a
VLeaf [(Bool
True, String
s)]

valid :: ValidatorResult
valid :: ValidatorResult
valid = [(Bool, String)] -> ValidatorResult
forall a. [a] -> VTree a
VLeaf []

mkTree :: [(Bool, String)] -> [ValidatorResult] -> ValidatorResult
mkTree :: [(Bool, String)] -> [ValidatorResult] -> ValidatorResult
mkTree = [(Bool, String)] -> [ValidatorResult] -> ValidatorResult
forall a. [a] -> [VTree a] -> VTree a
VNode

flattenT :: VTree a -> [a]
flattenT :: VTree a -> [a]
flattenT (VLeaf [a]
xs) = [a]
xs
flattenT (VNode [a]
as [VTree a]
bs) = [a]
as [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (VTree a -> [a]) -> [VTree a] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap VTree a -> [a]
forall a. VTree a -> [a]
flattenT [VTree a]
bs

validateEntry :: Element -> ValidatorResult
validateEntry :: Element -> ValidatorResult
validateEntry Element
e =
  [(Bool, String)] -> [ValidatorResult] -> ValidatorResult
mkTree
    []
    [ Element -> ValidatorResult
checkEntryAuthor Element
e
    , Element -> ValidatorResult
checkCats Element
e
    , Element -> ValidatorResult
checkContents Element
e
    , Element -> ValidatorResult
checkContributor Element
e
    , Element -> ValidatorResult
checkId Element
e
    , Element -> ValidatorResult
checkContentLink Element
e
    , Element -> ValidatorResult
checkLinks Element
e
    , Element -> ValidatorResult
checkPublished Element
e
    , Element -> ValidatorResult
checkRights Element
e
    , Element -> ValidatorResult
checkSource Element
e
    , Element -> ValidatorResult
checkSummary Element
e
    , Element -> ValidatorResult
checkTitle Element
e
    , Element -> ValidatorResult
checkUpdated Element
e
    ]

-- Sec 4.1.2, check #1
checkEntryAuthor :: Element -> ValidatorResult
checkEntryAuthor :: Element -> ValidatorResult
checkEntryAuthor Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"author" (Element -> [Element]
elementChildren Element
e) of
    [] -- required
     ->
      case Text -> [Element] -> Maybe Element
pNode Text
"summary" (Element -> [Element]
elementChildren Element
e) of
        Maybe Element
Nothing -> String -> ValidatorResult
demand String
"Required 'author' element missing (no 'summary' either)"
        Just Element
e1 ->
          case Text -> [Element] -> Maybe Element
pNode Text
"author" (Element -> [Element]
elementChildren Element
e1) of
            Just Element
a -> Element -> ValidatorResult
checkAuthor Element
a
            Maybe Element
_ -> String -> ValidatorResult
demand String
"Required 'author' element missing"
    [Element]
xs -> [(Bool, String)] -> [ValidatorResult] -> ValidatorResult
mkTree [] ([ValidatorResult] -> ValidatorResult)
-> [ValidatorResult] -> ValidatorResult
forall a b. (a -> b) -> a -> b
$ (Element -> ValidatorResult) -> [Element] -> [ValidatorResult]
forall a b. (a -> b) -> [a] -> [b]
map Element -> ValidatorResult
checkAuthor [Element]
xs

-- Sec 4.1.2, check #2
checkCats :: Element -> ValidatorResult
checkCats :: Element -> ValidatorResult
checkCats Element
e = [(Bool, String)] -> [ValidatorResult] -> ValidatorResult
mkTree [] ([ValidatorResult] -> ValidatorResult)
-> [ValidatorResult] -> ValidatorResult
forall a b. (a -> b) -> a -> b
$ (Element -> ValidatorResult) -> [Element] -> [ValidatorResult]
forall a b. (a -> b) -> [a] -> [b]
map Element -> ValidatorResult
checkCat (Text -> [Element] -> [Element]
pNodes Text
"category" (Element -> [Element]
elementChildren Element
e))

checkContents :: Element -> ValidatorResult
checkContents :: Element -> ValidatorResult
checkContents Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"content" (Element -> [Element]
elementChildren Element
e) of
    [] -> ValidatorResult
valid
    [Element
c] -> [(Bool, String)] -> [ValidatorResult] -> ValidatorResult
mkTree [] [Element -> ValidatorResult
checkContent Element
c]
    [Element]
cs ->
      [(Bool, String)] -> [ValidatorResult] -> ValidatorResult
mkTree
        (ValidatorResult -> [(Bool, String)]
forall a. VTree a -> [a]
flattenT
           (String -> ValidatorResult
demand
              (String
"at most one 'content' element expected inside 'entry', found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
cs))))
        ((Element -> ValidatorResult) -> [Element] -> [ValidatorResult]
forall a b. (a -> b) -> [a] -> [b]
map Element -> ValidatorResult
checkContent [Element]
cs)

checkContributor :: Element -> ValidatorResult
checkContributor :: Element -> ValidatorResult
checkContributor Element
_e = ValidatorResult
valid

checkContentLink :: Element -> ValidatorResult
checkContentLink :: Element -> ValidatorResult
checkContentLink Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"content" (Element -> [Element]
elementChildren Element
e) of
    [] ->
      case Text -> [Element] -> [Element]
pNodes Text
"link" (Element -> [Element]
elementChildren Element
e) of
        [] ->
          String -> ValidatorResult
demand
            String
"An 'entry' element with no 'content' element must have at least one 'link-rel' element"
        [Element]
xs ->
          case (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"alternate") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe Text) -> [Element] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> Element -> Maybe Text
pAttr Text
"rel") [Element]
xs of
            [] ->
              String -> ValidatorResult
demand
                String
"An 'entry' element with no 'content' element must have at least one 'link-rel' element"
            [Text]
_ -> ValidatorResult
valid
    [Element]
_ -> ValidatorResult
valid

checkLinks :: Element -> ValidatorResult
checkLinks :: Element -> ValidatorResult
checkLinks Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"link" (Element -> [Element]
elementChildren Element
e) of
    [Element]
xs ->
      case ((Element, Text) -> Element) -> [(Element, Text)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (Element, Text) -> Element
forall a b. (a, b) -> a
fst ([(Element, Text)] -> [Element]) -> [(Element, Text)] -> [Element]
forall a b. (a -> b) -> a -> b
$
           ((Element, Text) -> Bool) -> [(Element, Text)] -> [(Element, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Element
_, Text
n) -> Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"alternate") ([(Element, Text)] -> [(Element, Text)])
-> [(Element, Text)] -> [(Element, Text)]
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe (Element, Text))
-> [Element] -> [(Element, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Element
ex -> (Element
ex, ) (Text -> (Element, Text)) -> Maybe Text -> Maybe (Element, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Element -> Maybe Text
pAttr Text
"rel" Element
ex) [Element]
xs of
        [Element]
xs1 ->
          let jmb :: Maybe a -> Maybe b -> Maybe (a, b)
jmb (Just a
x) (Just b
y) = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
x, b
y)
              jmb Maybe a
_ Maybe b
_ = Maybe (a, b)
forall a. Maybe a
Nothing
           in case (Element -> Maybe (Text, Text)) -> [Element] -> [(Text, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Element
ex -> Text -> Element -> Maybe Text
pAttr Text
"type" Element
ex Maybe Text -> Maybe Text -> Maybe (Text, Text)
forall a b. Maybe a -> Maybe b -> Maybe (a, b)
`jmb` Text -> Element -> Maybe Text
pAttr Text
"hreflang" Element
ex) [Element]
xs1 of
                [(Text, Text)]
xs2 ->
                  if ([(Text, Text)] -> Bool) -> [[(Text, Text)]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\[(Text, Text)]
x -> [(Text, Text)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text)]
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) ([(Text, Text)] -> [[(Text, Text)]]
forall a. Eq a => [a] -> [[a]]
group [(Text, Text)]
xs2)
                    then String -> ValidatorResult
demand
                           String
"An 'entry' element cannot have duplicate 'link-rel-alternate-type-hreflang' elements"
                    else ValidatorResult
valid

checkId :: Element -> ValidatorResult
checkId :: Element -> ValidatorResult
checkId Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"id" (Element -> [Element]
elementChildren Element
e) of
    [] -> String -> ValidatorResult
demand String
"required field 'id' missing from 'entry' element"
    [Element
_] -> ValidatorResult
valid
    [Element]
xs -> String -> ValidatorResult
demand (String
"only one 'id' field expected in 'entry' element, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
xs))

checkPublished :: Element -> ValidatorResult
checkPublished :: Element -> ValidatorResult
checkPublished Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"published" (Element -> [Element]
elementChildren Element
e) of
    [] -> ValidatorResult
valid
    [Element
_] -> ValidatorResult
valid
    [Element]
xs ->
      String -> ValidatorResult
demand
        (String
"expected at most one 'published' field in 'entry' element, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
xs))

checkRights :: Element -> ValidatorResult
checkRights :: Element -> ValidatorResult
checkRights Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"rights" (Element -> [Element]
elementChildren Element
e) of
    [] -> ValidatorResult
valid
    [Element
_] -> ValidatorResult
valid
    [Element]
xs ->
      String -> ValidatorResult
demand (String
"expected at most one 'rights' field in 'entry' element, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
xs))

checkSource :: Element -> ValidatorResult
checkSource :: Element -> ValidatorResult
checkSource Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"source" (Element -> [Element]
elementChildren Element
e) of
    [] -> ValidatorResult
valid
    [Element
_] -> ValidatorResult
valid
    [Element]
xs ->
      String -> ValidatorResult
demand (String
"expected at most one 'source' field in 'entry' element, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
xs))

checkSummary :: Element -> ValidatorResult
checkSummary :: Element -> ValidatorResult
checkSummary Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"summary" (Element -> [Element]
elementChildren Element
e) of
    [] -> ValidatorResult
valid
    [Element
_] -> ValidatorResult
valid
    [Element]
xs ->
      String -> ValidatorResult
demand
        (String
"expected at most one 'summary' field in 'entry' element, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
xs))

checkTitle :: Element -> ValidatorResult
checkTitle :: Element -> ValidatorResult
checkTitle Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"title" (Element -> [Element]
elementChildren Element
e) of
    [] -> String -> ValidatorResult
demand String
"required field 'title' missing from 'entry' element"
    [Element
_] -> ValidatorResult
valid
    [Element]
xs -> String -> ValidatorResult
demand (String
"only one 'title' field expected in 'entry' element, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
xs))

checkUpdated :: Element -> ValidatorResult
checkUpdated :: Element -> ValidatorResult
checkUpdated Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"updated" (Element -> [Element]
elementChildren Element
e) of
    [] -> String -> ValidatorResult
demand String
"required field 'updated' missing from 'entry' element"
    [Element
_] -> ValidatorResult
valid
    [Element]
xs ->
      String -> ValidatorResult
demand (String
"only one 'updated' field expected in 'entry' element, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
xs))

checkCat :: Element -> ValidatorResult
checkCat :: Element -> ValidatorResult
checkCat Element
e = [(Bool, String)] -> [ValidatorResult] -> ValidatorResult
mkTree [] [Element -> ValidatorResult
checkTerm Element
e, Element -> ValidatorResult
checkScheme Element
e, Element -> ValidatorResult
checkLabel Element
e]
  where
    checkScheme :: Element -> ValidatorResult
checkScheme Element
e' =
      case Text -> Element -> [Text]
pAttrs Text
"scheme" Element
e' of
        [] -> ValidatorResult
valid
        (Text
_:[Text]
xs)
          | [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
xs -> ValidatorResult
valid
          | Bool
otherwise ->
            String -> ValidatorResult
demand (String
"Expected at most one 'scheme' attribute, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
xs))
    checkLabel :: Element -> ValidatorResult
checkLabel Element
e' =
      case Text -> Element -> [Text]
pAttrs Text
"label" Element
e' of
        [] -> ValidatorResult
valid
        (Text
_:[Text]
xs)
          | [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
xs -> ValidatorResult
valid
          | Bool
otherwise ->
            String -> ValidatorResult
demand (String
"Expected at most one 'label' attribute, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
xs))

checkContent :: Element -> ValidatorResult
checkContent :: Element -> ValidatorResult
checkContent Element
e =
  [(Bool, String)] -> [ValidatorResult] -> ValidatorResult
mkTree
    (ValidatorResult -> [(Bool, String)]
forall a. VTree a -> [a]
flattenT ([(Bool, String)] -> [ValidatorResult] -> ValidatorResult
mkTree [] [ValidatorResult
type_valid, ValidatorResult
src_valid]))
    [ case Text
ty of
        Text
"text" ->
          case Element -> [Element]
elementChildren Element
e of
            [] -> ValidatorResult
valid
            [Element]
_ -> String -> ValidatorResult
demand String
"content with type 'text' cannot have child elements, text only."
        Text
"html" ->
          case Element -> [Element]
elementChildren Element
e of
            [] -> ValidatorResult
valid
            [Element]
_ -> String -> ValidatorResult
demand String
"content with type 'html' cannot have child elements, text only."
        Text
"xhtml" ->
          case Element -> [Element]
elementChildren Element
e of
            [] -> ValidatorResult
valid
            [Element
_] -> ValidatorResult
valid -- ToDo: check that it is a 'div'.
            [Element]
_ds -> String -> ValidatorResult
demand String
"content with type 'xhtml' should only contain one 'div' child."
        Text
_ -> ValidatorResult
valid
    ]
  where
    types :: [Text]
types = Text -> Element -> [Text]
pAttrs Text
"type" Element
e
    (Text
ty, ValidatorResult
type_valid) =
      case [Text]
types of
        [] -> (Text
"text", ValidatorResult
valid)
        [Text
t] -> Text -> (Text, ValidatorResult)
forall a. (Eq a, IsString a) => a -> (a, ValidatorResult)
checkTypeA Text
t
        (Text
t:[Text]
ts) ->
          (Text
t, String -> ValidatorResult
demand (String
"Expected at most one 'type' attribute, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ts)))
    src_valid :: ValidatorResult
src_valid =
      case Text -> Element -> [Text]
pAttrs Text
"src" Element
e of
        [] -> ValidatorResult
valid
        [Text
_] ->
          case [Text]
types of
            [] -> String -> ValidatorResult
advice String
"It is advisable to provide a 'type' along with a 'src' attribute"
            (Text
_:[Text]
_) -> ValidatorResult
valid
        [Text]
ss -> String -> ValidatorResult
demand (String
"Expected at most one 'src' attribute, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ss))
    checkTypeA :: a -> (a, ValidatorResult)
checkTypeA a
v
      | a
v a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
std_types = (a
v, ValidatorResult
valid)
      | Bool
otherwise = (a
v, ValidatorResult
valid)
      where
        std_types :: [a]
std_types = [a
"text", a
"xhtml", a
"html"]

{-
      case parseMIMEType ty of
        Nothing -> valid
        Just mt
          | isXmlType mt -> valid
          | otherwise ->
            case onlyElems (elContent e) of
              [] -> valid -- check
              _  -> demand ("content with MIME type '" ++ ty ++ "' must only contain base64 data")]
-}
{-
            case parseMIMEType t of
              Just{} -> valid
              _      -> demand "The 'type' attribute must be a valid MIME type"
-}
{-
        case parseMIMEType v of
          Nothing -> ("text", demand ("Invalid/unknown type value " ++ v))
          Just mt ->
            case mimeType mt of
              Multipart{} -> ("text", demand "Multipart MIME types not a legal 'type'")
              _ -> (v, valid)
-}
checkTerm :: Element -> ValidatorResult
checkTerm :: Element -> ValidatorResult
checkTerm Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"term" (Element -> [Element]
elementChildren Element
e) of
    [] -> String -> ValidatorResult
demand String
"required field 'term' missing from 'category' element"
    [Element
_] -> ValidatorResult
valid
    [Element]
xs ->
      String -> ValidatorResult
demand (String
"only one 'term' field expected in 'category' element, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
xs))

checkAuthor :: Element -> ValidatorResult
checkAuthor :: Element -> ValidatorResult
checkAuthor = Element -> ValidatorResult
checkPerson

checkPerson :: Element -> ValidatorResult
checkPerson :: Element -> ValidatorResult
checkPerson Element
e = [(Bool, String)] -> [ValidatorResult] -> ValidatorResult
mkTree (ValidatorResult -> [(Bool, String)]
forall a. VTree a -> [a]
flattenT (ValidatorResult -> [(Bool, String)])
-> ValidatorResult -> [(Bool, String)]
forall a b. (a -> b) -> a -> b
$ Element -> ValidatorResult
checkName Element
e) [Element -> ValidatorResult
checkEmail Element
e, Element -> ValidatorResult
checkUri Element
e]

checkName :: Element -> ValidatorResult
checkName :: Element -> ValidatorResult
checkName Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"name" (Element -> [Element]
elementChildren Element
e) of
    [] -> String -> ValidatorResult
demand String
"required field 'name' missing from 'author' element"
    [Element
_] -> ValidatorResult
valid
    [Element]
xs -> String -> ValidatorResult
demand (String
"only one 'name' expected in 'author' element, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
xs))

checkEmail :: Element -> ValidatorResult
checkEmail :: Element -> ValidatorResult
checkEmail Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"email" (Element -> [Element]
elementChildren Element
e) of
    [] -> ValidatorResult
valid
    (Element
_:[Element]
xs)
      | [Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element]
xs -> ValidatorResult
valid
      | Bool
otherwise ->
        String -> ValidatorResult
demand (String
"at most one 'email' expected in 'author' element, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
xs))

checkUri :: Element -> ValidatorResult
checkUri :: Element -> ValidatorResult
checkUri Element
e =
  case Text -> [Element] -> [Element]
pNodes Text
"email" (Element -> [Element]
elementChildren Element
e) of
    [] -> ValidatorResult
valid
    (Element
_:[Element]
xs)
      | [Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element]
xs -> ValidatorResult
valid
      | Bool
otherwise ->
        String -> ValidatorResult
demand (String
"at most one 'uri' expected in 'author' element, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
xs))