Validate.hs

module Text.XHtml.FCKeditor.Validate
       (
         validate
       , fixup
       ) where

-- FIXME or should this be MTL?
import Network.CGI ( MonadIO, liftIO )
import Text.PrettyPrint.HughesPJ

import Text.XML.HaXml.Combinators
import Text.XML.HaXml.Parse ( xmlParse', dtdParse )
import Text.XML.HaXml.Pretty ( document, content )
import Text.XML.HaXml.Types ( Document(..), Content(CElem), Element(Elem) )
import Text.XML.HaXml.Validate ( partialValidate )

-- | Validate against the XHTML 1.0 Strict DTD using HaXML.
--
--   * If the given DTD relies on other files, then they must be in
--     the current directory of the process (a HaXML limitation).
--
--   * Wraps the contents in a @\<div\>@ in case there are several
--     tags. (HaXML assumes it is going to validate a single tree, not
--     a forest.) This influences errors but not the returned
--     Doc. Implies we can't validate a complete document (one with
--     head, body, etc.).
--
-- FIXME get the error handling right. @partialValidate@ likes to call "error",
-- so fix that.
-- If the lexer fails than "error" is called.
validate :: (MonadIO m)
         => FilePath -- ^ Filename of the DTD.
         -> String -- ^ "filename", for errors.
         -> String -- ^ Content to be validated.
         -> CFilter -- ^ Apply this filter to the content before validating.
         -> m (Doc, [String])
validate xhtmlDTDf filename contents f =
  do xhtmlDTD <- liftIO $ readFile xhtmlDTDf
     case dtdParse "xhtml1" xhtmlDTD of
       Nothing  -> fail $ "Parsing XHTML DTD failed."
       Just dtd ->
         case xmlParse' filename contents' of
           Left str -> return (text contents, [str])
           Right doc ->
             case onContent f doc of
               Left str -> return (document doc, [str])
               -- Remove the div in the returned document.
               -- We trust the content filter has not changed it.
               Right (Document _ _ elt@(Elem "div" [] cs) _) ->
                 return (vcat (map content cs), partialValidate dtd elt)
  where
    -- FIXME would like to do this more nicely...
    contents' = "<div>" ++ contents ++ "</div>"

onContent :: CFilter -> Document -> Either String Document
onContent f (Document p s e m) =
  case f (CElem e) of
    [CElem e'] -> Right (Document p s e' m)
    []         -> Left "FIXME filter produced no output"
    _          -> Left "FIXME filter produced more than one output"

-- | FIXME Munge some FCKeditor 2.5 non-XHtml infelicities.
--
--  * Turn \<embed\> into \<object\>.
fixup :: CFilter
fixup = foldXml (tag "embed" ?> replaceTag "object" :> keep)

{-

What we get:

<embed type="application/x-shockwave-flash"
            pluginspage="http://www.macromedia.com/go/getflashplayer"
            src="http://www.youtube.com/v/iUjFNJeWJ2s" width="425" height="355"
            play="true" loop="true" menu="true" />

What we want:

<object width="425" height="355"><param name="movie"
value="http://www.youtube.com/v/iUjFNJeWJ2s&rel=1"></param><param
name="wmode" value="transparent"></param></object>

-}