From 579583c1d2381141dc47a819be545534cde8b3f5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 28 Dec 2009 23:52:10 +0200 Subject: [PATCH] Added basic XML support --- Data/Object/Html.hs | 60 +++++++++++++++++++++++----------- Yesod/Helpers/AtomFeed.hs | 68 +++++++++++++-------------------------- Yesod/Helpers/Sitemap.hs | 47 +++++++++++---------------- Yesod/Rep.hs | 2 ++ 4 files changed, 84 insertions(+), 93 deletions(-) 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 "" + ] +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 "" + 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