{-# LANGUAGE TupleSections #-}
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
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
forall a. Show a => Int -> VTree a -> ShowS
forall a. Show a => [VTree a] -> ShowS
forall a. Show a => VTree a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [VTree a] -> ShowS
$cshowList :: forall a. Show a => [VTree a] -> ShowS
show :: VTree a -> [Char]
$cshow :: forall a. Show a => VTree a -> [Char]
showsPrec :: Int -> VTree a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> VTree a -> ShowS
Show)
type ValidatorResult = VTree (Bool, String)
advice :: String -> ValidatorResult
advice :: [Char] -> ValidatorResult
advice [Char]
s = forall a. [a] -> VTree a
VLeaf [(Bool
False, [Char]
s)]
demand :: String -> ValidatorResult
demand :: [Char] -> ValidatorResult
demand [Char]
s = forall a. [a] -> VTree a
VLeaf [(Bool
True, [Char]
s)]
valid :: ValidatorResult
valid :: ValidatorResult
valid = forall a. [a] -> VTree a
VLeaf []
mkTree :: [(Bool, String)] -> [ValidatorResult] -> ValidatorResult
mkTree :: [(Bool, [Char])] -> [ValidatorResult] -> ValidatorResult
mkTree = forall a. [a] -> [VTree a] -> VTree a
VNode
flattenT :: VTree a -> [a]
flattenT :: forall a. VTree a -> [a]
flattenT (VLeaf [a]
xs) = [a]
xs
flattenT (VNode [a]
as [VTree a]
bs) = [a]
as forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. VTree a -> [a]
flattenT [VTree a]
bs
validateEntry :: Element -> ValidatorResult
validateEntry :: Element -> ValidatorResult
validateEntry Element
e =
[(Bool, [Char])] -> [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
]
checkEntryAuthor :: Element -> ValidatorResult
checkEntryAuthor :: Element -> ValidatorResult
checkEntryAuthor Element
e =
case Text -> [Element] -> [Element]
pNodes Text
"author" (Element -> [Element]
elementChildren Element
e) of
[]
->
case Text -> [Element] -> Maybe Element
pNode Text
"summary" (Element -> [Element]
elementChildren Element
e) of
Maybe Element
Nothing -> [Char] -> ValidatorResult
demand [Char]
"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
_ -> [Char] -> ValidatorResult
demand [Char]
"Required 'author' element missing"
[Element]
xs -> [(Bool, [Char])] -> [ValidatorResult] -> ValidatorResult
mkTree [] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Element -> ValidatorResult
checkAuthor [Element]
xs
checkCats :: Element -> ValidatorResult
checkCats :: Element -> ValidatorResult
checkCats Element
e = [(Bool, [Char])] -> [ValidatorResult] -> ValidatorResult
mkTree [] forall a b. (a -> b) -> a -> b
$ 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, [Char])] -> [ValidatorResult] -> ValidatorResult
mkTree [] [Element -> ValidatorResult
checkContent Element
c]
[Element]
cs ->
[(Bool, [Char])] -> [ValidatorResult] -> ValidatorResult
mkTree
(forall a. VTree a -> [a]
flattenT
([Char] -> ValidatorResult
demand
([Char]
"at most one 'content' element expected inside 'entry', found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
cs))))
(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
[] ->
[Char] -> ValidatorResult
demand
[Char]
"An 'entry' element with no 'content' element must have at least one 'link-rel' element"
[Element]
xs ->
case forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
== Text
"alternate") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> Element -> Maybe Text
pAttr Text
"rel") [Element]
xs of
[] ->
[Char] -> ValidatorResult
demand
[Char]
"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 forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Element
_, Text
n) -> Text
n forall a. Eq a => a -> a -> Bool
== Text
"alternate") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Element
ex -> (Element
ex, ) 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) = forall a. a -> Maybe a
Just (a
x, b
y)
jmb Maybe a
_ Maybe b
_ = forall a. Maybe a
Nothing
in case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Element
ex -> Text -> Element -> Maybe Text
pAttr Text
"type" Element
ex 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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\[(Text, Text)]
x -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text)]
x forall a. Ord a => a -> a -> Bool
> Int
1) (forall a. Eq a => [a] -> [[a]]
group [(Text, Text)]
xs2)
then [Char] -> ValidatorResult
demand
[Char]
"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
[] -> [Char] -> ValidatorResult
demand [Char]
"required field 'id' missing from 'entry' element"
[Element
_] -> ValidatorResult
valid
[Element]
xs -> [Char] -> ValidatorResult
demand ([Char]
"only one 'id' field expected in 'entry' element, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (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 ->
[Char] -> ValidatorResult
demand
([Char]
"expected at most one 'published' field in 'entry' element, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (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 ->
[Char] -> ValidatorResult
demand ([Char]
"expected at most one 'rights' field in 'entry' element, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (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 ->
[Char] -> ValidatorResult
demand ([Char]
"expected at most one 'source' field in 'entry' element, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (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 ->
[Char] -> ValidatorResult
demand
([Char]
"expected at most one 'summary' field in 'entry' element, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (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
[] -> [Char] -> ValidatorResult
demand [Char]
"required field 'title' missing from 'entry' element"
[Element
_] -> ValidatorResult
valid
[Element]
xs -> [Char] -> ValidatorResult
demand ([Char]
"only one 'title' field expected in 'entry' element, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (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
[] -> [Char] -> ValidatorResult
demand [Char]
"required field 'updated' missing from 'entry' element"
[Element
_] -> ValidatorResult
valid
[Element]
xs ->
[Char] -> ValidatorResult
demand ([Char]
"only one 'updated' field expected in 'entry' element, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
xs))
checkCat :: Element -> ValidatorResult
checkCat :: Element -> ValidatorResult
checkCat Element
e = [(Bool, [Char])] -> [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)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
xs -> ValidatorResult
valid
| Bool
otherwise ->
[Char] -> ValidatorResult
demand ([Char]
"Expected at most one 'scheme' attribute, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
1 forall a. Num a => a -> a -> a
+ 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)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
xs -> ValidatorResult
valid
| Bool
otherwise ->
[Char] -> ValidatorResult
demand ([Char]
"Expected at most one 'label' attribute, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
xs))
checkContent :: Element -> ValidatorResult
checkContent :: Element -> ValidatorResult
checkContent Element
e =
[(Bool, [Char])] -> [ValidatorResult] -> ValidatorResult
mkTree
(forall a. VTree a -> [a]
flattenT ([(Bool, [Char])] -> [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]
_ -> [Char] -> ValidatorResult
demand [Char]
"content with type 'text' cannot have child elements, text only."
Text
"html" ->
case Element -> [Element]
elementChildren Element
e of
[] -> ValidatorResult
valid
[Element]
_ -> [Char] -> ValidatorResult
demand [Char]
"content with type 'html' cannot have child elements, text only."
Text
"xhtml" ->
case Element -> [Element]
elementChildren Element
e of
[] -> ValidatorResult
valid
[Element
_] -> ValidatorResult
valid
[Element]
_ds -> [Char] -> ValidatorResult
demand [Char]
"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] -> forall {a}. (Eq a, IsString a) => a -> (a, ValidatorResult)
checkTypeA Text
t
(Text
t:[Text]
ts) ->
(Text
t, [Char] -> ValidatorResult
demand ([Char]
"Expected at most one 'type' attribute, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
1 forall a. Num a => a -> a -> a
+ 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
[] -> [Char] -> ValidatorResult
advice [Char]
"It is advisable to provide a 'type' along with a 'src' attribute"
(Text
_:[Text]
_) -> ValidatorResult
valid
[Text]
ss -> [Char] -> ValidatorResult
demand ([Char]
"Expected at most one 'src' attribute, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ss))
checkTypeA :: a -> (a, ValidatorResult)
checkTypeA a
v
| a
v 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"]
checkTerm :: Element -> ValidatorResult
checkTerm :: Element -> ValidatorResult
checkTerm Element
e =
case Text -> [Element] -> [Element]
pNodes Text
"term" (Element -> [Element]
elementChildren Element
e) of
[] -> [Char] -> ValidatorResult
demand [Char]
"required field 'term' missing from 'category' element"
[Element
_] -> ValidatorResult
valid
[Element]
xs ->
[Char] -> ValidatorResult
demand ([Char]
"only one 'term' field expected in 'category' element, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (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, [Char])] -> [ValidatorResult] -> ValidatorResult
mkTree (forall a. VTree a -> [a]
flattenT 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
[] -> [Char] -> ValidatorResult
demand [Char]
"required field 'name' missing from 'author' element"
[Element
_] -> ValidatorResult
valid
[Element]
xs -> [Char] -> ValidatorResult
demand ([Char]
"only one 'name' expected in 'author' element, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (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)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element]
xs -> ValidatorResult
valid
| Bool
otherwise ->
[Char] -> ValidatorResult
demand ([Char]
"at most one 'email' expected in 'author' element, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
1 forall a. Num a => a -> a -> a
+ 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)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element]
xs -> ValidatorResult
valid
| Bool
otherwise ->
[Char] -> ValidatorResult
demand ([Char]
"at most one 'uri' expected in 'author' element, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
xs))