--------------------------------------------------------------------
-- |
-- 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 where

import Text.Atom.Feed.Import
import Text.XML.Light.Types
import Text.XML.Light.Proc


import Data.List
import Data.Maybe

data VTree a = VNode [a] [VTree a] | VLeaf [a]
     deriving (Eq, Show)

type ValidatorResult = VTree (Bool,String)

advice :: String -> ValidatorResult
advice s = VLeaf [(False,s)]

demand :: String -> ValidatorResult
demand s = VLeaf [(True,s)]

valid :: ValidatorResult
valid = VLeaf []

mkTree :: [(Bool,String)] -> [ValidatorResult] -> ValidatorResult
mkTree as bs = VNode as bs

flattenT :: VTree a -> [a]
flattenT (VLeaf xs) = xs
flattenT (VNode as bs) = as ++ concatMap flattenT bs

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

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


-- Sec 4.1.2, check #2
checkCats :: Element -> ValidatorResult
checkCats e = mkTree [] $ map checkCat (pNodes "category" (elChildren e))

checkContents :: Element -> ValidatorResult
checkContents e =
  case pNodes "content" (elChildren e) of
    []  -> valid
    [c] -> mkTree [] $ [checkContent c]
    cs  -> mkTree (flattenT (demand ("at most one 'content' element expected inside 'entry', found: " ++ show (length cs))))
                  (map checkContent cs)


checkContributor :: Element -> ValidatorResult
checkContributor _e = valid

checkContentLink :: Element -> ValidatorResult
checkContentLink e =
  case pNodes "content" (elChildren e) of
    [] ->
      case pNodes "link" (elChildren e) of
        [] -> demand ("An 'entry' element with no 'content' element must have at least one 'link-rel' element")
	xs ->
	  case filter (=="alternate") $ mapMaybe (pAttr "rel") xs of
	    [] -> demand ("An 'entry' element with no 'content' element must have at least one 'link-rel' element")
	    _  -> valid
    _ -> valid

checkLinks :: Element -> ValidatorResult
checkLinks e =
  case pNodes "link" (elChildren e) of
    xs ->
      case map fst $ filter (\ (_,n) -> n =="alternate") $
            mapMaybe (\ ex -> fmap (\x -> (ex,x)) $ pAttr "rel" ex) xs of
       xs1 ->
         let
	  jmb (Just x) (Just y) = Just (x,y)
	  jmb _ _ = Nothing
	 in
         case mapMaybe (\ ex -> pAttr "type" ex `jmb` pAttr "hreflang" ex) xs1 of
	   xs2 ->
	     case any (\ x -> length x > 1) (group xs2) of
	       True -> demand ("An 'entry' element cannot have duplicate 'link-rel-alternate-type-hreflang' elements")
	       _ -> valid

checkId :: Element -> ValidatorResult
checkId e =
  case pNodes "id" (elChildren e) of
    []  -> demand "required field 'id' missing from 'entry' element"
    [_] -> valid
    xs  -> demand ("only one 'id' field expected in 'entry' element, found: " ++ show (length xs))

checkPublished :: Element -> ValidatorResult
checkPublished e =
  case pNodes "published" (elChildren e) of
    []  -> valid
    [_] -> valid
    xs  -> demand ("expected at most one 'published' field in 'entry' element, found: " ++ show (length xs))

checkRights :: Element -> ValidatorResult
checkRights e =
  case pNodes "rights" (elChildren e) of
    []  -> valid
    [_] -> valid
    xs  -> demand ("expected at most one 'rights' field in 'entry' element, found: " ++ show (length xs))

checkSource :: Element -> ValidatorResult
checkSource e =
  case pNodes "source" (elChildren e) of
    []  -> valid
    [_] -> valid
    xs  -> demand ("expected at most one 'source' field in 'entry' element, found: " ++ show (length xs))

checkSummary :: Element -> ValidatorResult
checkSummary e =
  case pNodes "summary" (elChildren e) of
    []  -> valid
    [_] -> valid
    xs  -> demand ("expected at most one 'summary' field in 'entry' element, found: " ++ show (length xs))

checkTitle :: Element -> ValidatorResult
checkTitle e =
  case pNodes "title" (elChildren e) of
    []  -> demand "required field 'title' missing from 'entry' element"
    [_] -> valid
    xs  -> demand ("only one 'title' field expected in 'entry' element, found: " ++ show (length xs))

checkUpdated :: Element -> ValidatorResult
checkUpdated e =
  case pNodes "updated" (elChildren e) of
    []  -> demand "required field 'updated' missing from 'entry' element"
    [_] -> valid
    xs  -> demand ("only one 'updated' field expected in 'entry' element, found: " ++ show (length xs))

checkCat :: Element -> ValidatorResult
checkCat e = mkTree []
  [ checkTerm e
  , checkScheme e
  , checkLabel e
  ]
 where
  checkScheme e' =
    case pAttrs "scheme" e' of
      [] -> valid
      (_:xs)
        | null xs   -> valid
	| otherwise -> demand ("Expected at most one 'scheme' attribute, found: " ++ show (1+length xs))

  checkLabel e' =
    case pAttrs "label" e' of
      [] -> valid
      (_:xs)
        | null xs   -> valid
	| otherwise -> demand ("Expected at most one 'label' attribute, found: " ++ show (1+length xs))

checkContent :: Element -> ValidatorResult
checkContent e = mkTree (flattenT (mkTree [] [type_valid, src_valid]))
  [case ty of
    "text" ->
      case onlyElems (elContent e) of
        [] -> valid
	_  -> demand ("content with type 'text' cannot have child elements, text only.")
    "html" ->
      case onlyElems (elContent e) of
        [] -> valid
	_  -> demand ("content with type 'html' cannot have child elements, text only.")

    "xhtml" ->
      case onlyElems (elContent e) of
        []  -> valid
	[_] -> valid -- ToDo: check that it is a 'div'.
	_ds -> demand ("content with type 'xhtml' should only contain one 'div' child.")
    _ -> valid]
{-
      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")]
-}
 where
  types = pAttrs "type" e
  (ty, type_valid) =
    case types of
      []  -> ("text", valid)
      [t] -> checkTypeA t
      (t:ts) -> (t, demand ("Expected at most one 'type' attribute, found: " ++ show (1+length ts)))

  src_valid =
    case pAttrs "src" e of
      []     -> valid
      [_]   ->
        case types of
	  []    -> advice "It is advisable to provide a 'type' along with a 'src' attribute"
	  (_:_) -> valid
{-
	    case parseMIMEType t of
	      Just{} -> valid
	      _      -> demand "The 'type' attribute must be a valid MIME type"
-}
      ss -> demand ("Expected at most one 'src' attribute, found: " ++ show (length ss))


  checkTypeA v
    | v `elem` std_types = (v, valid)
    | otherwise = (v,valid)
{-
        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)
-}
   where
    std_types = [ "text", "xhtml", "html"]

checkTerm :: Element -> ValidatorResult
checkTerm e =
  case pNodes "term" (elChildren e) of
    []  -> demand "required field 'term' missing from 'category' element"
    [_] -> valid
    xs  -> demand ("only one 'term' field expected in 'category' element, found: " ++ show (length xs))

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

checkPerson :: Element -> ValidatorResult
checkPerson e =
   mkTree (flattenT $ checkName e)
          [ checkEmail e
          , checkUri e
          ]

checkName :: Element -> ValidatorResult
checkName e =
  case pNodes "name" (elChildren e) of
    []  -> demand "required field 'name' missing from 'author' element"
    [_] -> valid
    xs  -> demand ("only one 'name' expected in 'author' element, found: " ++ show (length xs))

checkEmail :: Element -> ValidatorResult
checkEmail e =
  case pNodes "email" (elChildren e) of
    [] -> valid
    (_:xs)
     | null xs   -> valid
     | otherwise -> demand ("at most one 'email' expected in 'author' element, found: " ++ show (1+length xs))

checkUri :: Element -> ValidatorResult
checkUri e =
  case pNodes "email" (elChildren e) of
    [] -> valid
    (_:xs)
     | null xs   -> valid
     | otherwise -> demand ("at most one 'uri' expected in 'author' element, found: " ++ show (1+length xs))