Added basic XML support

Data/Object/Html.hs

@@ -20,6 +20,9 @@ module Data.Object.Html
       Html (..)
     , HtmlDoc (..)
     , HtmlObject
+      -- * XML helpers
+    , XmlDoc (..)
+    , cdata
       -- * Standard 'Object' functions
     , toHtmlObject
     , fromHtmlObject
@@ -85,26 +88,47 @@ showAttribs = TL.concat . map helper where
         , cs "\""
         ]
 
+htmlToText :: Bool -- ^ True to close empty tags like XML, False like HTML
+           -> Html
+           -> Text
+htmlToText _ (Html t) = t
+htmlToText _ (Text t) = encodeHtml t
+htmlToText xml (Tag n as content) = TL.concat
+    [ cs "<"
+    , cs n
+    , showAttribs as
+    , cs ">"
+    , htmlToText xml content
+    , cs "</"
+    , cs n
+    , cs ">"
+    ]
+htmlToText xml (EmptyTag n as) = TL.concat
+    [ cs "<"
+    , cs n
+    , showAttribs as
+    , cs $ if xml then "/>" else ">"
+    ]
+htmlToText xml (HtmlList l) = TL.concat $ map (htmlToText xml) l
+
 instance ConvertSuccess Html Text where
-    convertSuccess (Html t) = t
+    convertSuccess = htmlToText False
-    convertSuccess (Text t) = encodeHtml t
+-- | Not fully typesafe. You must make sure that when converting to this, the
-    convertSuccess (Tag n as content) = TL.concat
+-- 'Html' starts with a tag.
-        [ cs "<"
+newtype XmlDoc = XmlDoc { unXmlDoc :: Text }
-        , cs n
+instance ConvertSuccess Html XmlDoc where
-        , showAttribs as
+    convertSuccess h = XmlDoc $ TL.concat
-        , cs ">"
+        [ cs "<?xml version='1.0' encoding='utf-8' ?>\n"
-        , cs content
+        , htmlToText True h
-        , cs "</"
-        , cs n
-        , cs ">"
         ]
-    convertSuccess (EmptyTag n as) = TL.concat
+
-        [ cs "<"
+-- | Wrap an 'Html' in CDATA for XML output.
-        , cs n
+cdata :: Html -> Html
-        , showAttribs as
+cdata h = HtmlList
-        , cs ">"
+    [ Html $ cs "<![CDATA["
-        ]
+    , h
-    convertSuccess (HtmlList l) = TL.concat $ map cs l
+    , Html $ cs "]]>"
+    ]
 
 instance ConvertSuccess Html String where
     convertSuccess = cs . (cs :: Html -> Text)

Yesod/Helpers/AtomFeed.hs

@@ -22,11 +22,8 @@ module Yesod.Helpers.AtomFeed
     ) where
 
 import Yesod
-import Data.Text.Lazy (Text)
+import Data.Time.Clock (UTCTime)
-import qualified Data.Text.Lazy as TL
+import Web.Encodings (formatW3)
-
-import Data.Time.Clock
-import Web.Encodings
 
 data AtomFeedResponse = AtomFeedResponse AtomFeed Approot
 
@@ -55,47 +52,26 @@ data AtomFeedEntry = AtomFeedEntry
     }
 
 instance ConvertSuccess AtomFeedResponse Content where
-    convertSuccess = (cs :: Text -> Content) . cs
+    convertSuccess = cs . (cs :: Html -> XmlDoc) . cs
-instance ConvertSuccess AtomFeedResponse Text where
+instance ConvertSuccess AtomFeedResponse Html where
-    convertSuccess (AtomFeedResponse f ar) = TL.concat
+    convertSuccess (AtomFeedResponse f ar) =
-        [ cs "<?xml version='1.0' encoding='utf-8' ?>\n"
+        Tag "feed" [("xmlns", "http://www.w3.org/2005/Atom")] $ HtmlList
-        , cs "<feed xmlns='http://www.w3.org/2005/Atom'>"
+          [ Tag "title" [] $ cs $ atomTitle f
-        , cs "<title>"
+          , EmptyTag "link" [ ("rel", "self")
-        , encodeHtml $ cs $ atomTitle f
+                            , ("href", showLocation ar $ atomLinkSelf f)
-        , cs "</title>"
+                            ]
-        , cs "<link rel='self' href='"
+          , EmptyTag "link" [ ("href", showLocation ar $ atomLinkHome f)
-        , encodeHtml $ cs $ showLocation ar $ atomLinkSelf f
+                            ]
-        , cs "'/>"
+          , Tag "updated" [] $ cs $ formatW3 $ atomUpdated f
-        , cs "<link href='"
+          , Tag "id" [] $ cs $ showLocation ar $ atomLinkHome f
-        , encodeHtml $ cs $ showLocation ar $ atomLinkHome f
+          , HtmlList $ map cs $ zip (atomEntries f) $ repeat ar
-        , cs "'/>"
-        , cs "<updated>"
-        , cs $ formatW3 $ atomUpdated f
-        , cs "</updated>"
-        , cs "<id>"
-        , encodeHtml $ cs $ showLocation ar $ atomLinkHome f
-        , cs "</id>"
-        , TL.concat $ map cs $ zip (atomEntries f) $ repeat ar
-        , cs "</feed>"
         ]
 
-instance ConvertSuccess (AtomFeedEntry, Approot) Text where
+instance ConvertSuccess (AtomFeedEntry, Approot) Html where
-    convertSuccess (e, ar) = TL.concat
+    convertSuccess (e, ar) = Tag "entry" [] $ HtmlList
-        [ cs "<entry>"
+        [ Tag "id" [] $ cs $ showLocation ar $ atomEntryLink e
-        , cs "<id>"
+        , EmptyTag "link" [("href", showLocation ar $ atomEntryLink e)]
-        , encodeHtml $ cs $ showLocation ar $ atomEntryLink e
+        , Tag "updated" [] $ cs $ formatW3 $ atomEntryUpdated e
-        , cs "</id>"
+        , Tag "title" [] $ cs $ atomEntryTitle e
-        , cs "<link href='"
+        , Tag "content" [("type", "html")] $ cdata $ atomEntryContent e
-        , encodeHtml $ cs $ showLocation ar $ atomEntryLink e
-        , cs "' />"
-        , cs "<updated>"
-        , cs $ formatW3 $ atomEntryUpdated e
-        , cs "</updated>"
-        , cs "<title>"
-        , encodeHtml $ cs $ atomEntryTitle e
-        , cs "</title>"
-        , cs "<content type='html'><![CDATA["
-        , cs $ atomEntryContent e
-        , cs "]]></content>"
-        , cs "</entry>"
         ]

Yesod/Helpers/Sitemap.hs

@@ -23,15 +23,9 @@ module Yesod.Helpers.Sitemap
     , SitemapResponse (..)
     ) where
 
-import Yesod.Definitions
+import Yesod
-import Yesod.Handler
+import Web.Encodings (formatW3)
-import Yesod.Rep
-import Web.Encodings
 import Data.Time (UTCTime)
-import Data.Convertible.Text
-import Data.Text.Lazy (Text)
-import qualified Data.Text.Lazy as TL
-import Yesod.Yesod
 
 data SitemapChangeFreq = Always
                        | Hourly
@@ -48,6 +42,8 @@ instance ConvertSuccess SitemapChangeFreq String where
     convertSuccess Monthly = "monthly"
     convertSuccess Yearly  = "yearly"
     convertSuccess Never   = "never"
+instance ConvertSuccess SitemapChangeFreq Html where
+    convertSuccess = (cs :: String -> Html) . cs
 
 data SitemapUrl = SitemapUrl
     { sitemapLoc :: Location
@@ -57,27 +53,20 @@ data SitemapUrl = SitemapUrl
     }
 data SitemapResponse = SitemapResponse [SitemapUrl] Approot
 instance ConvertSuccess SitemapResponse Content where
-    convertSuccess = cs . (cs :: SitemapResponse -> Text)
+    convertSuccess = cs . (cs :: Html -> XmlDoc) . cs
-instance ConvertSuccess SitemapResponse Text where
+instance ConvertSuccess SitemapResponse Html where
-    convertSuccess (SitemapResponse urls ar) = TL.concat
+    convertSuccess (SitemapResponse urls ar) =
-        [ cs "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
+        Tag "urlset" [("xmlns", sitemapNS)] $ HtmlList $ map helper urls
-        , cs "<urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\">"
+          where
-        , TL.concat $ map helper urls
+            sitemapNS = "http://www.sitemaps.org/schemas/sitemap/0.9"
-        , cs "</urlset>"
+            helper :: SitemapUrl -> Html
-        ]
+            helper (SitemapUrl loc modTime freq pri) =
-        where
+                Tag "url" [] $ HtmlList
-            helper (SitemapUrl loc modTime freq pri) = cs $ concat
+                    [ Tag "loc" [] $ cs $ showLocation ar loc
-                -- FIXME use HTML?
+                    , Tag "lastmod" [] $ cs $ formatW3 modTime
-                [ "<url><loc>"
+                    , Tag "changefreq" [] $ cs freq
-                , encodeHtml $ showLocation ar loc
+                    , Tag "priority" [] $ cs $ show pri
-                , "</loc><lastmod>"
+                    ]
-                , formatW3 modTime
-                , "</lastmod><changefreq>"
-                , cs freq
-                , "</changefreq><priority>"
-                , show pri
-                , "</priority></url>"
-                ]
 
 instance HasReps SitemapResponse where
     reps =

Yesod/Rep.hs

@@ -111,6 +111,8 @@ instance ConvertSuccess String Content where
     convertSuccess = Content . cs
 instance ConvertSuccess Html Content where
     convertSuccess = Content . cs
+instance ConvertSuccess XmlDoc Content where
+    convertSuccess = cs . unXmlDoc
 
 type ContentPair = (ContentType, Content)
 type RepChooser = [ContentType] -> IO ContentPair