diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs
index 0b03716f..7fa1e602 100644
--- 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 "\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 ""
+ ]
instance ConvertSuccess Html String where
convertSuccess = cs . (cs :: Html -> Text)
diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs
index ca63fba0..b0377c32 100644
--- 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 "\n"
- , cs ""
- , cs ""
- , encodeHtml $ cs $ atomTitle f
- , cs ""
- , cs ""
- , cs ""
- , cs ""
- , cs $ formatW3 $ atomUpdated f
- , cs ""
- , cs ""
- , encodeHtml $ cs $ showLocation ar $ atomLinkHome f
- , cs ""
- , TL.concat $ map cs $ zip (atomEntries f) $ repeat ar
- , cs ""
+ 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 ""
- , cs ""
- , encodeHtml $ cs $ showLocation ar $ atomEntryLink e
- , cs ""
- , cs ""
- , cs ""
- , cs $ formatW3 $ atomEntryUpdated e
- , cs ""
- , cs ""
- , encodeHtml $ cs $ atomEntryTitle e
- , cs ""
- , cs ""
- , cs ""
+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
]
diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs
index d41c1ebc..04780092 100644
--- 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 "\n"
- , cs ""
- , TL.concat $ map helper urls
- , cs ""
- ]
- where
- helper (SitemapUrl loc modTime freq pri) = cs $ concat
- -- FIXME use HTML?
- [ ""
- , encodeHtml $ showLocation ar loc
- , ""
- , formatW3 modTime
- , ""
- , cs freq
- , ""
- , show pri
- , ""
- ]
+ 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 =
diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs
index 9c4eb487..c69d3ffa 100644
--- 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