1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
|
--------------------------------------------------------------------
-- |
-- Module : Text.RSS1.Export
-- Copyright : (c) Galois, Inc. 2008
-- License : BSD3
--
-- Maintainer: Sigbjorn Finne <sof@galois.com>
-- Stability : provisional
-- Portability:
--
--------------------------------------------------------------------
module Text.RSS1.Export
( xmlFeed
) where
import Text.XML.Light as XML
import Text.RSS1.Syntax
import Text.RSS1.Utils
import Text.DublinCore.Types
import Data.List
import Data.Maybe
qualNode :: (Maybe String,Maybe String) -> String -> [XML.Content] -> XML.Element
qualNode ns n cs =
blank_element
{ elName = qualName ns n
, elContent = cs
}
---
xmlFeed :: Feed -> XML.Element
xmlFeed f =
(qualNode (rdfNS,rdfPrefix) "RDF" $ map Elem $
(concat [ [xmlChannel (feedChannel f)]
, mb xmlImage (feedImage f)
, map xmlItem (feedItems f)
, mb xmlTextInput (feedTextInput f)
, map xmlTopic (feedTopics f)
, feedOther f
] ))
-- should we expect these to be derived by the XML pretty printer..?
{ elAttribs = nub $
Attr (qualName (Nothing,Nothing) "xmlns") (fromJust rss10NS) :
Attr (qualName (Nothing,Just "xmlns") (fromJust rdfPrefix)) (fromJust rdfNS) :
Attr (qualName (Nothing,Just "xmlns") (fromJust synPrefix)) (fromJust synNS) :
Attr (qualName (Nothing,Just "xmlns") (fromJust taxPrefix)) (fromJust taxNS) :
Attr (qualName (Nothing,Just "xmlns") (fromJust conPrefix)) (fromJust conNS) :
Attr (qualName (Nothing,Just "xmlns") (fromJust dcPrefix)) (fromJust dcNS) :
feedAttrs f}
xmlChannel :: Channel -> XML.Element
xmlChannel ch =
(qualNode (rss10NS,Nothing) "channel" $ map Elem $
([ xmlLeaf (rss10NS,Nothing) "title" (channelTitle ch)
, xmlLeaf (rss10NS,Nothing) "link" (channelLink ch)
, xmlLeaf (rss10NS,Nothing) "description" (channelDesc ch)
] ++
mb xmlTextInputURI (channelTextInputURI ch) ++
mb xmlImageURI (channelImageURI ch) ++
xmlItemURIs (channelItemURIs ch) ++ map xmlDC (channelDC ch) ++
concat [ mb xmlUpdatePeriod (channelUpdatePeriod ch)
, mb xmlUpdateFreq (channelUpdateFreq ch)
, mb (xmlLeaf (synNS,synPrefix) "updateBase") (channelUpdateBase ch)
] ++
xmlContentItems (channelContent ch) ++
xmlTopics (channelTopics ch) ++
channelOther ch))
{ elAttribs = ( Attr (qualName (rdfNS,rdfPrefix) "about") (channelURI ch) :
channelAttrs ch)}
xmlImageURI :: URIString -> XML.Element
xmlImageURI u = xmlEmpty (rss10NS,Nothing) "image" [Attr (rdfName "resource") u ]
xmlImage :: Image -> XML.Element
xmlImage i =
(qualNode (rss10NS,Nothing) "image" $ map Elem $
([ xmlLeaf (rss10NS,Nothing) "title" (imageTitle i)
, xmlLeaf (rss10NS,Nothing) "url" (imageURL i)
, xmlLeaf (rss10NS,Nothing) "link" (imageLink i)
] ++ map xmlDC (imageDC i) ++
imageOther i))
{ elAttribs = ( Attr (qualName (rdfNS,rdfPrefix) "about") (imageURI i) :
imageAttrs i)}
xmlItemURIs :: [URIString] -> [XML.Element]
xmlItemURIs [] = []
xmlItemURIs xs =
[qualNode (rss10NS, Nothing) "items" $
[Elem (qualNode (rdfNS,rdfPrefix) "Seq" (map toRes xs))]]
where
toRes u = Elem (xmlEmpty (rdfNS,rdfPrefix) "li" [Attr (rdfName "resource") u])
xmlTextInputURI :: URIString -> XML.Element
xmlTextInputURI u = xmlEmpty (rss10NS,Nothing) "textinput" [Attr (rdfName "resource") u ]
xmlTextInput :: TextInputInfo -> XML.Element
xmlTextInput ti =
(qualNode (rss10NS, Nothing) "textinput" $ map Elem $
[ xmlLeaf (rss10NS,Nothing) "title" (textInputTitle ti)
, xmlLeaf (rss10NS,Nothing) "description" (textInputDesc ti)
, xmlLeaf (rss10NS,Nothing) "name" (textInputName ti)
, xmlLeaf (rss10NS,Nothing) "link" (textInputLink ti)
] ++ map xmlDC (textInputDC ti) ++
textInputOther ti)
{elAttribs=Attr (rdfName "about") (textInputURI ti) : textInputAttrs ti}
xmlDC :: DCItem -> XML.Element
xmlDC dc = xmlLeaf (dcNS,dcPrefix) (infoToTag (dcElt dc)) (dcText dc)
xmlUpdatePeriod :: UpdatePeriod -> XML.Element
xmlUpdatePeriod u = xmlLeaf (synNS,synPrefix) "updatePeriod" (toStr u)
where
toStr ux =
case ux of
Update_Hourly -> "hourly"
Update_Daily -> "daily"
Update_Weekly -> "weekly"
Update_Monthly -> "monthly"
Update_Yearly -> "yearly"
xmlUpdateFreq :: Integer -> XML.Element
xmlUpdateFreq f = xmlLeaf (synNS,synPrefix) "updateFrequency" (show f)
xmlContentItems :: [ContentInfo] -> [XML.Element]
xmlContentItems [] = []
xmlContentItems xs =
[qualNode (conNS,conPrefix) "items"
[Elem $ qualNode (rdfNS,rdfPrefix) "Bag"
(map (\ e -> Elem (qualNode (rdfNS,rdfPrefix) "li" [Elem (xmlContentInfo e)]))
xs)]]
xmlContentInfo :: ContentInfo -> XML.Element
xmlContentInfo ci =
(qualNode (conNS,conPrefix) "item" $ map Elem $
(concat [ mb (rdfResource (conNS,conPrefix) "format") (contentFormat ci)
, mb (rdfResource (conNS,conPrefix) "encoding") (contentEncoding ci)
, mb (rdfValue []) (contentValue ci)
]))
{elAttribs=mb (Attr (rdfName "about")) (contentURI ci)}
rdfResource :: (Maybe String,Maybe String) -> String -> String -> XML.Element
rdfResource ns t v = xmlEmpty ns t [Attr (rdfName "resource") v ]
rdfValue :: [XML.Attr] -> String -> XML.Element
rdfValue as s = (xmlLeaf (rdfNS,rdfPrefix) "value" s){elAttribs=as}
xmlTopics :: [URIString] -> [XML.Element]
xmlTopics [] = []
xmlTopics xs =
[qualNode (taxNS,taxPrefix) "topics"
[Elem (qualNode (rdfNS,rdfPrefix) "Bag" $
(map (Elem . rdfResource (rdfNS,rdfPrefix) "li") xs))]]
xmlTopic :: TaxonomyTopic -> XML.Element
xmlTopic tt =
(qualNode (taxNS,taxPrefix) "topic" $ map Elem $
(xmlLeaf (rss10NS,Nothing) "link" (taxonomyLink tt):
mb (xmlLeaf (rss10NS,Nothing) "title") (taxonomyTitle tt) ++
mb (xmlLeaf (rss10NS,Nothing) "description") (taxonomyDesc tt) ++
xmlTopics (taxonomyTopics tt) ++
map xmlDC (taxonomyDC tt) ++
taxonomyOther tt))
{elAttribs=[Attr (rdfName "about") (taxonomyURI tt)]}
xmlItem :: Item -> XML.Element
xmlItem i =
(qualNode (rss10NS,Nothing) "item" $ map Elem $
([ xmlLeaf (rss10NS,Nothing) "title" (itemTitle i)
, xmlLeaf (rss10NS,Nothing) "link" (itemLink i)
] ++
mb (xmlLeaf (rss10NS,Nothing) "description") (itemDesc i) ++
map xmlDC (itemDC i) ++
xmlTopics (itemTopics i) ++
map xmlContentInfo (itemContent i) ++
itemOther i))
{ elAttribs = ( Attr (qualName (rdfNS,rdfPrefix) "about") (itemURI i) :
itemAttrs i)}
xmlLeaf :: (Maybe String,Maybe String) -> String -> String -> XML.Element
xmlLeaf ns tg txt =
blank_element{ elName = qualName ns tg
, elContent = [ Text blank_cdata { cdData = txt } ]
}
xmlEmpty :: (Maybe String,Maybe String) -> String -> [XML.Attr] -> XML.Element
xmlEmpty ns t as = (qualNode ns t []){elAttribs=as}
---
mb :: (a -> b) -> Maybe a -> [b]
mb _ Nothing = []
mb f (Just x) = [f x]
|
