feed-0.3.9: Text/Feed/Constructor.hs
--------------------------------------------------------------------
-- |
-- Module : Text.Feed.Constructor
-- Copyright : (c) Galois, Inc. 2008
-- License : BSD3
--
-- Maintainer: Sigbjorn Finne <sof@galois.com>
-- Stability : provisional
-- Description: Module for an abstraction layer between different kinds of feeds.
--
--------------------------------------------------------------------
module Text.Feed.Constructor
( FeedKind(..)
, newFeed -- :: FeedKind -> Feed
, feedFromRSS -- :: RSS -> Feed
, feedFromAtom -- :: Atom.Feed -> Feed
, feedFromRDF -- :: RSS1.Feed -> Feed
, feedFromXML -- :: Element -> Feed
, getFeedKind -- :: Feed -> FeedKind
, FeedSetter -- type _ a = a -> Feed -> Feed
, addItem -- :: FeedSetter Item
, withFeedTitle -- :: FeedSetter String
, withFeedHome -- :: FeedSetter URLString
, withFeedHTML -- :: FeedSetter URLString
, withFeedDescription -- :: FeedSetter String
, withFeedPubDate -- :: FeedSetter DateString
, withFeedLastUpdate -- :: FeedSetter DateString
, withFeedDate -- :: FeedSetter DateString
, withFeedLogoLink -- :: FeedSetter URLString
, withFeedLanguage -- :: FeedSetter String
, withFeedCategories -- :: FeedSetter [(String,Maybe String)]
, withFeedGenerator -- :: FeedSetter String
, withFeedItems -- :: FeedSetter [Item]
, newItem -- :: FeedKind -> Item
, getItemKind -- :: Item -> FeedKind
, atomEntryToItem -- :: Atom.Entry -> Item
, rssItemToItem -- :: RSS.Item -> Item
, rdfItemToItem -- :: RSS1.Item -> Item
, ItemSetter -- type _ a = a -> Item -> Item
, withItemTitle -- :: ItemSetter String
, withItemLink -- :: ItemSetter URLString
, withItemPubDate -- :: ItemSetter DateString
, withItemDate -- :: ItemSetter DateString
, withItemAuthor -- :: ItemSetter String
, withItemCommentLink -- :: ItemSetter String
, withItemEnclosure -- :: String -> Maybe String -> ItemSetter Integer
, withItemFeedLink -- :: String -> ItemSetter String
, withItemId -- :: Bool -> ItemSetter String
, withItemCategories -- :: ItemSetter [(String, Maybe String)]
, withItemDescription -- :: ItemSetter String
, withItemRights -- :: ItemSetter String
) where
import Text.Feed.Types as Feed.Types
import Text.Atom.Feed as Atom
import Text.RSS.Syntax as RSS
import Text.RSS1.Syntax as RSS1
import Text.DublinCore.Types
import Text.XML.Light as XML hiding ( filterChildren )
import Data.Maybe ( fromMaybe, mapMaybe )
import Data.Char ( toLower )
-- ToDo:
--
-- - complete set of constructors over feeds
-- - provide a unified treatment of date string reps.
-- (i.e., I know they differ across formats, but ignorant what
-- the constraints are at the moment.)
-- | Construct an empty feed document, intending to output it in
-- the 'fk' feed format.
newFeed :: FeedKind -> Feed.Types.Feed
newFeed fk =
case fk of
AtomKind -> AtomFeed (Atom.nullFeed "feed-id-not-filled-in"
(TextString "dummy-title")
"dummy-and-bogus-update-date")
RSSKind mbV ->
let def = (RSS.nullRSS "dummy-title" "default-channel-url") in
RSSFeed $ fromMaybe def $ fmap (\ v -> def{RSS.rssVersion=v}) mbV
RDFKind mbV ->
let def = (RSS1.nullFeed "default-channel-url" "dummy-title") in
RSS1Feed $ fromMaybe def $ fmap (\ v -> def{RSS1.feedVersion=v}) mbV
feedFromRSS :: RSS.RSS -> Feed.Types.Feed
feedFromRSS r = RSSFeed r
feedFromAtom :: Atom.Feed -> Feed.Types.Feed
feedFromAtom f = AtomFeed f
feedFromRDF :: RSS1.Feed -> Feed.Types.Feed
feedFromRDF f = RSS1Feed f
feedFromXML :: XML.Element -> Feed.Types.Feed
feedFromXML f = XMLFeed f
getFeedKind :: Feed.Types.Feed -> FeedKind
getFeedKind f =
case f of
Feed.Types.AtomFeed{} -> AtomKind
Feed.Types.RSSFeed r -> RSSKind (case RSS.rssVersion r of { "2.0" -> Nothing; v -> Just v})
Feed.Types.RSS1Feed r -> RDFKind (case RSS1.feedVersion r of { "1.0" -> Nothing; v -> Just v})
Feed.Types.XMLFeed{} -> RSSKind (Just "2.0") -- for now, just a hunch..
addItem :: Feed.Types.Item -> Feed.Types.Feed -> Feed.Types.Feed
addItem it f =
case (it,f) of
(Feed.Types.AtomItem e, Feed.Types.AtomFeed fe) ->
Feed.Types.AtomFeed fe{Atom.feedEntries=e:Atom.feedEntries fe}
(Feed.Types.RSSItem e, Feed.Types.RSSFeed r) ->
Feed.Types.RSSFeed r{RSS.rssChannel=(RSS.rssChannel r){RSS.rssItems=e:RSS.rssItems (RSS.rssChannel r)}}
(Feed.Types.RSS1Item e, Feed.Types.RSS1Feed r) ->
-- note: do not update the channel item URIs at this point;
-- will delay doing so until serialization.
Feed.Types.RSS1Feed r{RSS1.feedItems=e:RSS1.feedItems r}
_ -> error "addItem: currently unable to automatically convert items from one feed type to another"
withFeedItems :: FeedSetter [Feed.Types.Item]
withFeedItems is fe =
foldr addItem
(case fe of
Feed.Types.AtomFeed f -> Feed.Types.AtomFeed
f{Atom.feedEntries=[]}
Feed.Types.RSSFeed f -> Feed.Types.RSSFeed
f{rssChannel=(rssChannel f){rssItems=[]}}
Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed
f{feedItems=[]})
is
newItem :: FeedKind -> Feed.Types.Item
newItem fk =
case fk of
AtomKind -> Feed.Types.AtomItem $
Atom.nullEntry "entry-id-not-filled-in"
(TextString "dummy-entry-title")
"dummy-and-bogus-entry-update-date"
RSSKind{} -> Feed.Types.RSSItem $
RSS.nullItem "dummy-rss-item-title"
RDFKind{} -> Feed.Types.RSS1Item $
RSS1.nullItem "dummy-item-uri"
"dummy-item-title"
"dummy-item-link"
getItemKind :: Feed.Types.Item -> FeedKind
getItemKind f =
case f of
Feed.Types.AtomItem{} -> AtomKind
Feed.Types.RSSItem{} -> RSSKind (Just "2.0") -- good guess..
Feed.Types.RSS1Item{} -> RDFKind (Just "1.0")
Feed.Types.XMLItem{} -> RSSKind (Just "2.0")
type FeedSetter a = a -> Feed.Types.Feed -> Feed.Types.Feed
withFeedTitle :: FeedSetter String
withFeedTitle tit fe =
case fe of
Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedTitle=TextString tit}
Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{rssChannel=(rssChannel f){rssTitle=tit}}
Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f{feedChannel=(feedChannel f){channelTitle=tit}}
Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $
mapMaybeChildren (\ e ->
if (elName e == unqual "channel")
then Just (mapMaybeChildren (\ e2 ->
if (elName e2 == unqual "title")
then Just (unode "title" tit)
else Nothing) e)
else Nothing) f
withFeedHome :: FeedSetter URLString
withFeedHome url fe =
case fe of
Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedLinks=newSelf:Atom.feedLinks f}
-- ToDo: fix, the <link> element is for the HTML home of the channel, not the
-- location of the feed itself. Struggling to find if there is a common way
-- to represent this outside of RSS 2.0 standard elements..
Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{rssChannel=(rssChannel f){rssLink=url}}
Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f{feedChannel=(feedChannel f){channelURI=url}}
Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $
mapMaybeChildren (\ e ->
if (elName e == unqual "channel")
then Just (mapMaybeChildren (\ e2 ->
if (elName e2 == unqual "link")
then Just (unode "link" url)
else Nothing) e)
else Nothing) f
where
newSelf = (nullLink url){ linkRel=Just (Left "self")
, linkType=Just "application/atom+xml"
}
-- | 'withFeedHTML' sets the URL where an HTML version of the
-- feed is published.
withFeedHTML :: FeedSetter URLString
withFeedHTML url fe =
case fe of
Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f{feedLinks=newAlt:Atom.feedLinks f}
Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f{rssChannel=(rssChannel f){rssLink=url}}
Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f{feedChannel=(feedChannel f){channelLink=url}}
Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $
mapMaybeChildren (\ e ->
if (elName e == unqual "channel")
then Just (mapMaybeChildren (\ e2 ->
if (elName e2 == unqual "link")
then Just (unode "link" url)
else Nothing) e)
else Nothing) f
where
newAlt = (nullLink url){ linkRel=Just (Left "alternate")
, linkType=Just "text/html"
}
-- | 'withFeedHTML' sets the URL where an HTML version of the
-- feed is published.
withFeedDescription :: FeedSetter String
withFeedDescription desc fe =
case fe of
Feed.Types.AtomFeed f -> Feed.Types.AtomFeed
f{feedSubtitle=Just (TextString desc)}
Feed.Types.RSSFeed f -> Feed.Types.RSSFeed
f{rssChannel=(rssChannel f){rssDescription=desc}}
Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed
f{feedChannel=(feedChannel f){channelDesc=desc}}
Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $
mapMaybeChildren (\ e ->
if (elName e == unqual "channel")
then Just (mapMaybeChildren (\ e2 ->
if (elName e2 == unqual "description")
then Just (unode "description" desc)
else Nothing) e)
else Nothing) f
withFeedPubDate :: FeedSetter String
withFeedPubDate dateStr fe =
case fe of
Feed.Types.AtomFeed f -> Feed.Types.AtomFeed
f{feedUpdated=dateStr}
Feed.Types.RSSFeed f -> Feed.Types.RSSFeed
f{rssChannel=(rssChannel f){rssPubDate=Just dateStr}}
Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $
case break isDate $ RSS1.channelDC (RSS1.feedChannel f) of
(as,(dci:bs)) ->
f{RSS1.feedChannel=
(RSS1.feedChannel f)
{RSS1.channelDC=as++dci{dcText=dateStr}:bs}}
(_,[]) ->
f{RSS1.feedChannel=
(RSS1.feedChannel f)
{RSS1.channelDC=
DCItem{dcElt=DC_Date,dcText=dateStr}:
RSS1.channelDC (RSS1.feedChannel f)}}
Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $
mapMaybeChildren (\ e ->
if (elName e == unqual "channel")
then Just (mapMaybeChildren (\ e2 ->
if (elName e2 == unqual "pubDate")
then Just (unode "pubDate" dateStr)
else Nothing) e)
else Nothing) f
where
isDate dc = dcElt dc == DC_Date
withFeedLastUpdate :: FeedSetter DateString
withFeedLastUpdate dateStr fe =
case fe of
Feed.Types.AtomFeed f -> Feed.Types.AtomFeed
f{feedUpdated=dateStr}
Feed.Types.RSSFeed f -> Feed.Types.RSSFeed
f{rssChannel=(rssChannel f){rssLastUpdate=Just dateStr}}
Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $
case break isDate $ RSS1.channelDC (RSS1.feedChannel f) of
(as,(dci:bs)) ->
f{RSS1.feedChannel=
(RSS1.feedChannel f)
{RSS1.channelDC=as++dci{dcText=dateStr}:bs}}
(_,[]) ->
f{RSS1.feedChannel=
(RSS1.feedChannel f)
{RSS1.channelDC=
DCItem{dcElt=DC_Date,dcText=dateStr}:
RSS1.channelDC (RSS1.feedChannel f)}}
Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $
mapMaybeChildren (\ e ->
if (elName e == unqual "channel")
then Just (mapMaybeChildren (\ e2 ->
if (elName e2 == unqual "lastUpdate")
then Just (unode "lastUpdate" dateStr)
else Nothing) e)
else Nothing) f
where
isDate dc = dcElt dc == DC_Date
-- | 'withFeedDate dt' is the composition of 'withFeedPubDate'
-- and 'withFeedLastUpdate', setting both publication date and
-- last update date to 'dt'. Notice that RSS2.0 is the only format
-- supporting both pub and last-update.
withFeedDate :: FeedSetter DateString
withFeedDate dt f = withFeedPubDate dt(withFeedLastUpdate dt f)
withFeedLogoLink :: URLString -> FeedSetter URLString
withFeedLogoLink imgURL lnk fe =
case fe of
Feed.Types.AtomFeed f -> Feed.Types.AtomFeed
f{ feedLogo = Just imgURL
, feedLinks = newSelf:Atom.feedLinks f
}
Feed.Types.RSSFeed f -> Feed.Types.RSSFeed
f{ rssChannel=(rssChannel f)
{rssImage=Just $
RSS.nullImage imgURL (rssTitle (rssChannel f)) lnk}}
Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $
f{ feedImage = Just $
RSS1.nullImage imgURL (RSS1.channelTitle (RSS1.feedChannel f)) lnk
, feedChannel =
(feedChannel f){channelImageURI=Just imgURL}
}
Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $
mapMaybeChildren (\ e ->
if (elName e == unqual "channel")
then Just (mapMaybeChildren (\ e2 ->
if (elName e2 == unqual "image")
then Just (unode "image" [ unode "url" imgURL
, unode "title" title
, unode "link" lnk
])
else Nothing) e)
else Nothing) f
where
title =
case fmap (findChild (unqual "title"))
(findChild (unqual "channel") f) of
Just (Just e1) -> strContent e1
_ -> "feed_title" -- shouldn't happen..
where
newSelf = (nullLink lnk){ linkRel=Just (Left "self")
, linkType=Just "application/atom+xml"
}
withFeedLanguage :: FeedSetter String
withFeedLanguage lang fe =
case fe of
Feed.Types.AtomFeed f -> Feed.Types.AtomFeed $
f{Atom.feedAttrs=(XML.Attr (unqual "lang"){qPrefix=Just "xml"} lang):Atom.feedAttrs f}
Feed.Types.RSSFeed f -> Feed.Types.RSSFeed
f{rssChannel=(rssChannel f){rssLanguage=Just lang}}
Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $
case break isLang $ RSS1.channelDC (RSS1.feedChannel f) of
(as,(dci:bs)) ->
f{RSS1.feedChannel=
(RSS1.feedChannel f)
{RSS1.channelDC=as++dci{dcText=lang}:bs}}
(_,[]) ->
f{RSS1.feedChannel=
(RSS1.feedChannel f)
{RSS1.channelDC=
DCItem{dcElt=DC_Language,dcText=lang}:
RSS1.channelDC (RSS1.feedChannel f)}}
Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $
mapMaybeChildren (\ e ->
if (elName e == unqual "channel")
then Just (mapMaybeChildren (\ e2 ->
if (elName e2 == unqual "language")
then Just (unode "language" lang)
else Nothing) e)
else Nothing) f
where
isLang dc = dcElt dc == DC_Language
withFeedCategories :: FeedSetter [(String,Maybe String)]
withFeedCategories cats fe =
case fe of
Feed.Types.AtomFeed f -> Feed.Types.AtomFeed
f{ Atom.feedCategories =
map ( \ (t,mb) -> (Atom.newCategory t){Atom.catScheme=mb})
cats ++ feedCategories f}
Feed.Types.RSSFeed f -> Feed.Types.RSSFeed
f{rssChannel=(rssChannel f){
RSS.rssCategories=
map (\ (t,mb) -> (RSS.newCategory t){RSS.rssCategoryDomain=mb})
cats ++ RSS.rssCategories (rssChannel f)}}
Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed
f{feedChannel=(feedChannel f){
RSS1.channelDC=
map (\ (t,_) -> DCItem{dcElt=DC_Subject,dcText=t})
cats ++ RSS1.channelDC (feedChannel f)}}
Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $
mapMaybeChildren (\ e ->
if (elName e == unqual "channel")
then Just (
foldr
(\ (t,mb) acc ->
addChild (unode "category"
(fromMaybe (\x -> [x])
(fmap (\v -> (\ x -> [Attr (unqual "domain") v,x])) mb) $
(Attr (unqual "term") t))
) acc)
e
cats)
else Nothing) f
withFeedGenerator :: FeedSetter (String,Maybe URLString)
withFeedGenerator (gen,mbURI) fe =
case fe of
Feed.Types.AtomFeed f -> Feed.Types.AtomFeed $
f{Atom.feedGenerator=Just ((Atom.nullGenerator gen){Atom.genURI=mbURI})}
Feed.Types.RSSFeed f -> Feed.Types.RSSFeed
f{rssChannel=(rssChannel f){rssGenerator=Just gen}}
Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $
case break isSource $ RSS1.channelDC (RSS1.feedChannel f) of
(as,(dci:bs)) ->
f{RSS1.feedChannel=
(RSS1.feedChannel f)
{RSS1.channelDC=as++dci{dcText=gen}:bs}}
(_,[]) ->
f{RSS1.feedChannel=
(RSS1.feedChannel f)
{RSS1.channelDC=
DCItem{dcElt=DC_Source,dcText=gen}:
RSS1.channelDC (RSS1.feedChannel f)}}
Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $
mapMaybeChildren (\ e ->
if (elName e == unqual "channel")
then Just (mapMaybeChildren (\ e2 ->
if (elName e2 == unqual "generator")
then Just (unode "generator" gen)
else Nothing) e)
else Nothing) f
where
isSource dc = dcElt dc == DC_Source
-- Item constructors (all the way to the end):
atomEntryToItem :: Atom.Entry -> Feed.Types.Item
atomEntryToItem e = Feed.Types.AtomItem e
rssItemToItem :: RSS.RSSItem -> Feed.Types.Item
rssItemToItem i = Feed.Types.RSSItem i
rdfItemToItem :: RSS1.Item -> Feed.Types.Item
rdfItemToItem i = Feed.Types.RSS1Item i
type ItemSetter a = a -> Feed.Types.Item -> Feed.Types.Item
-- | 'withItemPubDate dt' associates the creation\/ publication date 'dt'
-- with a feed item.
withItemPubDate :: ItemSetter DateString
withItemPubDate dt fi =
case fi of
Feed.Types.AtomItem e ->
Feed.Types.AtomItem e{Atom.entryUpdated=dt}
Feed.Types.RSSItem i ->
Feed.Types.RSSItem i{RSS.rssItemPubDate=Just dt}
Feed.Types.RSS1Item i ->
case break isDate $ RSS1.itemDC i of
(as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=dt}:bs}
(_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Date,dcText=dt}:RSS1.itemDC i}
Feed.Types.XMLItem i ->
Feed.Types.XMLItem $
addChild (unode "pubDate" dt) $
filterChildren (\ e -> elName e /= unqual "pubDate")
i
where
isDate dc = dcElt dc == DC_Date
-- | 'withItemDate' is a synonym for 'withItemPubDate'.
withItemDate :: ItemSetter DateString
withItemDate dt fi = withItemPubDate dt fi
-- | 'withItemTitle myTitle' associates a new title, 'myTitle',
-- with a feed item.
withItemTitle :: ItemSetter String
withItemTitle tit fi =
case fi of
Feed.Types.AtomItem e ->
Feed.Types.AtomItem e{Atom.entryTitle=TextString tit}
Feed.Types.RSSItem i ->
Feed.Types.RSSItem i{RSS.rssItemTitle=Just tit}
Feed.Types.RSS1Item i ->
Feed.Types.RSS1Item i{RSS1.itemTitle=tit}
Feed.Types.XMLItem i ->
Feed.Types.XMLItem $
addChild (unode "title" tit) $
filterChildren (\ e -> elName e /= unqual "title")
i
-- | 'withItemAuthor auStr' associates new author info
-- with a feed item.
withItemAuthor :: ItemSetter String
withItemAuthor au fi =
case fi of
Feed.Types.AtomItem e ->
Feed.Types.AtomItem e{Atom.entryAuthors=[nullPerson{personName=au,personURI=Just au}]}
Feed.Types.RSSItem i ->
Feed.Types.RSSItem i{RSS.rssItemAuthor=Just au}
Feed.Types.RSS1Item i ->
case break isAuthor $ RSS1.itemDC i of
(as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=au}:bs}
(_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Creator,dcText=au}:RSS1.itemDC i}
Feed.Types.XMLItem i ->
Feed.Types.XMLItem $
addChild (unode "author" au) $
filterChildren (\ e -> elName e /= unqual "author")
i
where
isAuthor dc = dcElt dc == DC_Creator
-- | 'withItemFeedLink name myFeed' associates the parent feed URL 'myFeed'
-- with a feed item. It is labelled as 'name'.
withItemFeedLink :: String -> ItemSetter String
withItemFeedLink tit url fi =
case fi of
Feed.Types.AtomItem e ->
Feed.Types.AtomItem e{Atom.entrySource=Just Atom.nullSource{sourceId=Just url,sourceTitle=Just (TextString tit)}}
Feed.Types.RSSItem i ->
Feed.Types.RSSItem i{RSS.rssItemSource=Just (RSS.nullSource url tit)}
Feed.Types.RSS1Item i ->
Feed.Types.RSS1Item i{RSS1.itemTitle=tit}
Feed.Types.XMLItem i ->
Feed.Types.XMLItem $
addChild (unode "source" (Attr (unqual "url") url,tit)) $
filterChildren (\ e -> elName e /= unqual "source")
i
-- | 'withItemCommentLink url' sets the URL reference to the comment page to 'url'.
withItemCommentLink :: ItemSetter String
withItemCommentLink url fi =
case fi of
Feed.Types.AtomItem e ->
Feed.Types.AtomItem e{Atom.entryLinks=((nullLink url){linkRel=Just (Left "replies")}):Atom.entryLinks e}
Feed.Types.RSSItem i ->
Feed.Types.RSSItem i{RSS.rssItemComments=Just url}
Feed.Types.RSS1Item i ->
case break isRel $ RSS1.itemDC i of
(as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=url}:bs}
(_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Relation,dcText=url}:RSS1.itemDC i}
Feed.Types.XMLItem i ->
Feed.Types.XMLItem $
addChild (unode "comments" url) $
filterChildren (\ e -> elName e /= unqual "comments")
i
where
isRel dc = dcElt dc == DC_Relation
-- | 'withItemEnclosure url mbTy len' sets the URL reference to the comment page to 'url'.
withItemEnclosure :: String -> Maybe String -> ItemSetter Integer
withItemEnclosure url ty len fi =
case fi of
Feed.Types.AtomItem e -> Feed.Types.AtomItem
e{Atom.entryLinks=((nullLink url){linkRel=Just (Left "enclosure")
,linkType=ty
,linkLength=Just (show len)
}):Atom.entryLinks e}
Feed.Types.RSSItem i ->
Feed.Types.RSSItem i{RSS.rssItemEnclosure=Just (nullEnclosure url len (fromMaybe "text/html" ty))}
Feed.Types.RSS1Item i -> Feed.Types.RSS1Item
i{RSS1.itemContent=nullContentInfo{ contentURI=Just url
, contentFormat=ty
}:RSS1.itemContent i}
Feed.Types.XMLItem i ->
Feed.Types.XMLItem $
addChild ((unode "enclosure" url)
{elAttribs= [ Attr (unqual "length") "0"
, Attr (unqual "type") (fromMaybe "text/html" ty)
]}) $
filterChildren (\ e -> elName e /= unqual "enclosure")
i
-- | 'withItemId isURL id' associates new unique identifier with a feed item.
-- If 'isURL' is 'True', then the id is assumed to point to a valid web resource.
withItemId :: Bool -> ItemSetter String
withItemId isURL idS fi =
case fi of
Feed.Types.AtomItem e ->
Feed.Types.AtomItem e{Atom.entryId=idS}
Feed.Types.RSSItem i ->
Feed.Types.RSSItem i{RSS.rssItemGuid=Just (nullGuid idS){rssGuidPermanentURL=Just isURL}}
Feed.Types.RSS1Item i ->
case break isId $ RSS1.itemDC i of
(as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=idS}:bs}
(_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Identifier,dcText=idS}:RSS1.itemDC i}
Feed.Types.XMLItem i ->
Feed.Types.XMLItem $
addChild (unode "guid" (Attr (unqual "isPermaLink") (showBool isURL),idS)) $
filterChildren (\ e -> elName e /= unqual "guid")
i
where
showBool x = map toLower (show x)
isId dc = dcElt dc == DC_Identifier
-- | 'withItemDescription desc' associates a new descriptive string (aka summary)
-- with a feed item.
withItemDescription :: ItemSetter String
withItemDescription desc fi =
case fi of
Feed.Types.AtomItem e ->
Feed.Types.AtomItem e{Atom.entrySummary=Just (TextString desc)}
Feed.Types.RSSItem i ->
Feed.Types.RSSItem i{RSS.rssItemDescription=Just desc}
Feed.Types.RSS1Item i ->
Feed.Types.RSS1Item i{RSS1.itemDesc=Just desc}
Feed.Types.XMLItem i ->
Feed.Types.XMLItem $
addChild (unode "description" desc) $
filterChildren (\ e -> elName e /= unqual "description")
i
-- | 'withItemRights rightStr' associates the rights information 'rightStr'
-- with a feed item.
withItemRights :: ItemSetter String
withItemRights desc fi =
case fi of
Feed.Types.AtomItem e ->
Feed.Types.AtomItem e{Atom.entryRights=Just (TextString desc)}
-- Note: per-item copyright information isn't supported by RSS2.0 (and earlier editions),
-- you can only attach this at the feed/channel level. So, there's not much we can do
-- except dropping the information on the floor here. (Rolling our own attribute or
-- extension element is an option, but would prefer if someone else had started that
-- effort already.
Feed.Types.RSSItem{} -> fi
Feed.Types.RSS1Item i ->
case break ((==DC_Rights).dcElt) $ RSS1.itemDC i of
(as,(dci:bs)) -> Feed.Types.RSS1Item i{RSS1.itemDC=as++dci{dcText=desc}:bs}
(_,[]) -> Feed.Types.RSS1Item i{RSS1.itemDC=DCItem{dcElt=DC_Rights,dcText=desc}:RSS1.itemDC i}
-- Since we're so far assuming that a shallow XML rep. of an item
-- is of RSS2.0 ilk, pinning on the rights info is hard (see above.)
Feed.Types.XMLItem{} -> fi
-- | 'withItemTitle myLink' associates a new URL, 'myLink',
-- with a feed item.
withItemLink :: ItemSetter URLString
withItemLink url fi =
case fi of
Feed.Types.AtomItem e ->
Feed.Types.AtomItem e{Atom.entryLinks=replaceAlternate url (Atom.entryLinks e)}
Feed.Types.RSSItem i ->
Feed.Types.RSSItem i{RSS.rssItemLink=Just url}
Feed.Types.RSS1Item i ->
Feed.Types.RSS1Item i{RSS1.itemLink=url}
Feed.Types.XMLItem i ->
Feed.Types.XMLItem $
addChild (unode "link" url) $
filterChildren (\ e -> elName e /= unqual "link")
i
where
replaceAlternate _ [] = []
replaceAlternate x (lr:xs)
| toStr (Atom.linkRel lr) == "alternate" = lr{Atom.linkHref=x} : xs
| otherwise = lr : replaceAlternate x xs
toStr Nothing = ""
toStr (Just (Left x)) = x
toStr (Just (Right x)) = x
withItemCategories :: ItemSetter [(String,Maybe String)]
withItemCategories cats fi =
case fi of
Feed.Types.AtomItem e -> Feed.Types.AtomItem
e{ Atom.entryCategories =
map ( \ (t,mb) -> (Atom.newCategory t){Atom.catScheme=mb})
cats ++ entryCategories e}
Feed.Types.RSSItem i -> Feed.Types.RSSItem
i{RSS.rssItemCategories=
map (\ (t,mb) -> (RSS.newCategory t){RSS.rssCategoryDomain=mb})
cats ++ rssItemCategories i}
Feed.Types.RSS1Item i -> Feed.Types.RSS1Item
i{RSS1.itemDC=
map (\ (t,_) -> DCItem{dcElt=DC_Subject,dcText=t})
cats ++ RSS1.itemDC i}
Feed.Types.XMLItem i -> Feed.Types.XMLItem $
foldr (\ (t,mb) acc ->
addChild (unode "category"
(fromMaybe (\x -> [x])
(fmap (\v -> (\ x -> [Attr (unqual "domain") v,x])) mb) $
(Attr (unqual "term") t))
) acc)
i
cats
-- helpers..
filterChildren :: (XML.Element -> Bool) -> XML.Element -> XML.Element
filterChildren pre e =
case elContent e of
[] -> e
cs -> e { elContent = mapMaybe filterElt cs }
where
filterElt xe@(XML.Elem el)
| pre el = Just xe
| otherwise = Nothing
filterElt xe = Just xe
addChild :: XML.Element -> XML.Element -> XML.Element
addChild a b = b { elContent = XML.Elem a : elContent b }
mapMaybeChildren :: (XML.Element -> Maybe XML.Element)
-> XML.Element
-> XML.Element
mapMaybeChildren f e =
case elContent e of
[] -> e
cs -> e { elContent = map procElt cs }
where
procElt xe@(XML.Elem el) =
case f el of
Nothing -> xe
Just el1 -> XML.Elem el1
procElt xe = xe