Added basic XML support

2009-12-28 23:52:10 +02:00 · 2009-12-28 23:52:10 +02:00 · 579583c1d2
commit 579583c1d2
parent dc355edf7d
4 changed files with 84 additions and 93 deletions
--- a/Data/Object/Html.hs
+++ b/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 (Text t) = encodeHtml t
-    convertSuccess (Tag n as content) = TL.concat
-        [ cs "<"
-        , cs n
-        , showAttribs as
-        , cs ">"
-        , cs content
-        , cs "</"
-        , cs n
-        , cs ">"
+    convertSuccess = htmlToText False
+-- | Not fully typesafe. You must make sure that when converting to this, the
+-- 'Html' starts with a tag.
+newtype XmlDoc = XmlDoc { unXmlDoc :: Text }
+instance ConvertSuccess Html XmlDoc where
+    convertSuccess h = XmlDoc $ TL.concat
+        [ cs "<?xml version='1.0' encoding='utf-8' ?>\n"
+        , htmlToText True h
        ]
-    convertSuccess (EmptyTag n as) = TL.concat
-        [ cs "<"
-        , cs n
-        , showAttribs as
-        , cs ">"
-        ]
-    convertSuccess (HtmlList l) = TL.concat $ map cs l
+
+-- | Wrap an 'Html' in CDATA for XML output.
+cdata :: Html -> Html
+cdata h = HtmlList
+    [ Html $ cs "<![CDATA["
+    , h
+    , Html $ cs "]]>"
+    ]

 instance ConvertSuccess Html String where
    convertSuccess = cs . (cs :: Html -> Text)
--- a/Yesod/Helpers/AtomFeed.hs
+++ b/Yesod/Helpers/AtomFeed.hs
@ -22,11 +22,8 @@ module Yesod.Helpers.AtomFeed
    ) where

 import Yesod
-import Data.Text.Lazy (Text)
-import qualified Data.Text.Lazy as TL
-
-import Data.Time.Clock
-import Web.Encodings
+import Data.Time.Clock (UTCTime)
+import Web.Encodings (formatW3)

 data AtomFeedResponse = AtomFeedResponse AtomFeed Approot

@ -55,47 +52,26 @@ data AtomFeedEntry = AtomFeedEntry
    }

 instance ConvertSuccess AtomFeedResponse Content where
-    convertSuccess = (cs :: Text -> Content) . cs
-instance ConvertSuccess AtomFeedResponse Text where
-    convertSuccess (AtomFeedResponse f ar) = TL.concat
-        [ cs "<?xml version='1.0' encoding='utf-8' ?>\n"
-        , cs "<feed xmlns='http://www.w3.org/2005/Atom'>"
-        , cs "<title>"
-        , encodeHtml $ cs $ atomTitle f
-        , cs "</title>"
-        , cs "<link rel='self' href='"
-        , encodeHtml $ cs $ showLocation ar $ atomLinkSelf f
-        , cs "'/>"
-        , cs "<link href='"
-        , encodeHtml $ cs $ showLocation ar $ atomLinkHome f
-        , 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>"
+    convertSuccess = cs . (cs :: Html -> XmlDoc) . cs
+instance ConvertSuccess AtomFeedResponse Html where
+    convertSuccess (AtomFeedResponse f ar) =
+        Tag "feed" [("xmlns", "http://www.w3.org/2005/Atom")] $ HtmlList
+          [ Tag "title" [] $ cs $ atomTitle f
+          , EmptyTag "link" [ ("rel", "self")
+                            , ("href", showLocation ar $ atomLinkSelf f)
+                            ]
+          , EmptyTag "link" [ ("href", showLocation ar $ atomLinkHome f)
+                            ]
+          , Tag "updated" [] $ cs $ formatW3 $ atomUpdated f
+          , Tag "id" [] $ cs $ showLocation ar $ atomLinkHome f
+          , HtmlList $ map cs $ zip (atomEntries f) $ repeat ar
        ]

-instance ConvertSuccess (AtomFeedEntry, Approot) Text where
-    convertSuccess (e, ar) = TL.concat
-        [ cs "<entry>"
-        , cs "<id>"
-        , encodeHtml $ cs $ showLocation ar $ atomEntryLink e
-        , cs "</id>"
-        , cs "<link href='"
-        , 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>"
+instance ConvertSuccess (AtomFeedEntry, Approot) Html where
+    convertSuccess (e, ar) = Tag "entry" [] $ HtmlList
+        [ Tag "id" [] $ cs $ showLocation ar $ atomEntryLink e
+        , EmptyTag "link" [("href", showLocation ar $ atomEntryLink e)]
+        , Tag "updated" [] $ cs $ formatW3 $ atomEntryUpdated e
+        , Tag "title" [] $ cs $ atomEntryTitle e
+        , Tag "content" [("type", "html")] $ cdata $ atomEntryContent e
        ]
--- a/Yesod/Helpers/Sitemap.hs
+++ b/Yesod/Helpers/Sitemap.hs
@ -23,15 +23,9 @@ module Yesod.Helpers.Sitemap
    , SitemapResponse (..)
    ) where

-import Yesod.Definitions
-import Yesod.Handler
-import Yesod.Rep
-import Web.Encodings
+import Yesod
+import Web.Encodings (formatW3)
 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)
-instance ConvertSuccess SitemapResponse Text where
-    convertSuccess (SitemapResponse urls ar) = TL.concat
-        [ cs "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
-        , cs "<urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\">"
-        , TL.concat $ map helper urls
-        , cs "</urlset>"
-        ]
-        where
-            helper (SitemapUrl loc modTime freq pri) = cs $ concat
-                -- FIXME use HTML?
-                [ "<url><loc>"
-                , encodeHtml $ showLocation ar loc
-                , "</loc><lastmod>"
-                , formatW3 modTime
-                , "</lastmod><changefreq>"
-                , cs freq
-                , "</changefreq><priority>"
-                , show pri
-                , "</priority></url>"
-                ]
+    convertSuccess = cs . (cs :: Html -> XmlDoc) . cs
+instance ConvertSuccess SitemapResponse Html where
+    convertSuccess (SitemapResponse urls ar) =
+        Tag "urlset" [("xmlns", sitemapNS)] $ HtmlList $ map helper urls
+          where
+            sitemapNS = "http://www.sitemaps.org/schemas/sitemap/0.9"
+            helper :: SitemapUrl -> Html
+            helper (SitemapUrl loc modTime freq pri) =
+                Tag "url" [] $ HtmlList
+                    [ Tag "loc" [] $ cs $ showLocation ar loc
+                    , Tag "lastmod" [] $ cs $ formatW3 modTime
+                    , Tag "changefreq" [] $ cs freq
+                    , Tag "priority" [] $ cs $ show pri
+                    ]

 instance HasReps SitemapResponse where
    reps =
--- a/Yesod/Rep.hs
+++ b/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