module Web.Atom
( makeFeed
, makeEntry
, feedXML
, entryXML
, XMLGen (..)
, Feed(..)
, Entry(..)
, Source(..)
, Content(..)
, Category(..)
, Generator(..)
, Person(..)
, Email(..)
, Rel(..)
, Text(..)
, Link(..)
, LanguageTag(..)
, MediaType(..)
, UTCTime
, unsafeURI
, URI(..)
) where
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BC
import Data.Maybe (catMaybes, fromJust)
import Data.String (IsString (..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T (decodeUtf8)
import Data.Time (UTCTime, formatTime)
import Network.URI (URI (..), parseURI)
import System.Locale (defaultTimeLocale)
makeFeed :: URI
-> Text e
-> UTCTime
-> Feed e
makeFeed uri title updated = Feed
{ feedId = uri
, feedTitle = title
, feedUpdated = updated
, feedSubtitle = Nothing
, feedIcon = Nothing
, feedLogo = Nothing
, feedRights = Nothing
, feedGenerator = Nothing
, feedAuthors = []
, feedContributors = []
, feedCategories = []
, feedLinks = []
, feedEntries = []
}
makeEntry :: URI
-> Text e
-> UTCTime
-> Entry e
makeEntry uri title updated = Entry
{ entryId = uri
, entryTitle = title
, entryUpdated = updated
, entryPublished = Nothing
, entrySummary = Nothing
, entryContent = Nothing
, entryRights = Nothing
, entrySource = Nothing
, entryAuthors = []
, entryContributors = []
, entryCategories = []
, entryLinks = []
}
unsafeURI :: String -> URI
unsafeURI = fromJust . parseURI
feedXML :: XMLGen e node name attr -> Feed e -> e
feedXML xmlgen feed = toXML xmlgen "feed" feed
entryXML :: XMLGen e node name attr -> Entry e -> e
entryXML xmlgen entry = toXML xmlgen "entry" entry
data XMLGen elem node name attr = XMLGen { xmlElem :: name -> [attr] ->
[node] -> elem
, xmlName :: Maybe T.Text -> T.Text -> name
, xmlAttr :: name -> T.Text -> attr
, xmlTextNode :: T.Text -> node
, xmlElemNode :: elem -> node
}
data LanguageTag = LanguageTag T.Text deriving (Show, Eq)
data Email = Email T.Text deriving (Show, Eq)
data MediaType = MediaType ByteString deriving (Show, Eq)
data Rel = RelText T.Text | RelURI URI deriving (Eq)
instance Show Rel where
show (RelText t) = T.unpack t
show (RelURI u) = show u
instance IsString MediaType where
fromString s = MediaType (BC.pack s)
data Text e = TextPlain T.Text
| TextHTML T.Text
| TextXHTML e
deriving (Show, Eq)
instance IsString (Text e) where
fromString s = TextPlain (T.pack s)
data Content e = InlinePlainContent T.Text
| InlineHTMLContent T.Text
| InlineXHTMLContent e
| InlineXMLContent e (Maybe MediaType)
| InlineTextContent T.Text (Maybe MediaType)
| InlineBase64Content ByteString (Maybe MediaType)
| OutOfLineContent URI (Maybe MediaType)
deriving (Show, Eq)
data Person = Person
{ personName :: T.Text
, personURI :: Maybe URI
, personEmail :: Maybe Email
} deriving (Show, Eq)
data Generator = Generator
{ generatorName :: T.Text
, generatorURI :: Maybe URI
, version :: Maybe T.Text
} deriving (Show, Eq)
data Category = Category
{ categoryTerm :: T.Text
, categoryScheme :: Maybe URI
, categoryLabel :: Maybe T.Text
} deriving (Show, Eq)
data Link = Link
{ linkHref :: URI
, linkRel :: Maybe Rel
, linkType :: Maybe MediaType
, linkHrefLang :: Maybe LanguageTag
, linkTitle :: Maybe T.Text
, linkLength :: Maybe Integer
} deriving (Show, Eq)
data Feed e = Feed
{ feedId :: URI
, feedTitle :: Text e
, feedUpdated :: UTCTime
, feedSubtitle :: Maybe (Text e)
, feedIcon :: Maybe URI
, feedLogo :: Maybe URI
, feedRights :: Maybe (Text e)
, feedGenerator :: Maybe Generator
, feedAuthors :: [Person]
, feedContributors :: [Person]
, feedCategories :: [Category]
, feedLinks :: [Link]
, feedEntries :: [Entry e]
} deriving (Show, Eq)
data Source e = Source
{ sourceId :: Maybe URI
, sourceTitle :: Maybe (Text e)
, sourceUpdated :: Maybe UTCTime
, sourceSubtitle :: Maybe (Text e)
, sourceIcon :: Maybe URI
, sourceLogo :: Maybe URI
, sourceRights :: Maybe (Text e)
, sourceGenerator :: Maybe Generator
, sourceAuthors :: [Person]
, sourceContributors :: [Person]
, sourceCategories :: [Category]
, sourceLinks :: [Link]
} deriving (Show, Eq)
data Entry e = Entry
{ entryId :: URI
, entryTitle :: (Text e)
, entryUpdated :: UTCTime
, entryPublished :: Maybe UTCTime
, entrySummary :: Maybe (Text e)
, entryContent :: Maybe (Content e)
, entryRights :: Maybe (Text e)
, entrySource :: Maybe (Source e)
, entryAuthors :: [Person]
, entryContributors :: [Person]
, entryCategories :: [Category]
, entryLinks :: [Link]
} deriving (Show, Eq)
textShow :: (Show a) => a -> T.Text
textShow = T.pack . show
atomNS :: Maybe T.Text
atomNS = Just "http://www.w3.org/2005/Atom"
media :: XMLGen e n m a -> MediaType -> a
media XMLGen{..} (MediaType m) = xmlAttr (xmlName Nothing "type") (T.decodeUtf8 m)
attr :: XMLGen e n m a -> T.Text -> T.Text -> a
attr XMLGen{..} name value = xmlAttr (xmlName Nothing name) value
class ToXML e b where
toXML :: XMLGen e n m a -> T.Text -> b -> e
instance ToXML e (Feed e) where
toXML g@XMLGen{..} tag Feed{..} = xmlElem (xmlName atomNS tag) [] $
map xmlElemNode (
[ toXML g "id" feedId
, toXML g "title" feedTitle
, toXML g "updated" feedUpdated
]
++ catMaybes
[ fmap (toXML g "subtitle") feedSubtitle
, fmap (toXML g "icon") feedIcon
, fmap (toXML g "logo") feedLogo
, fmap (toXML g "rights") feedRights
, fmap (toXML g "generator") feedGenerator
]
++ map (toXML g "author") feedAuthors
++ map (toXML g "contributor") feedContributors
++ map (toXML g "category") feedCategories
++ map (toXML g "link") feedLinks
++ map (toXML g "entry") feedEntries
)
instance ToXML e (Entry e) where
toXML g@XMLGen{..} tag Entry{..} = xmlElem (xmlName atomNS tag) [] $
map xmlElemNode (
[ toXML g "id" entryId
, toXML g "title" entryTitle
, toXML g "updated" entryUpdated
]
++ catMaybes
[ fmap (toXML g "published") entryPublished
, fmap (toXML g "summary") entrySummary
, fmap (toXML g "content") entryContent
, fmap (toXML g "rights") entryRights
, fmap (toXML g "source") entrySource
]
++ map (toXML g "author") entryAuthors
++ map (toXML g "contributor") entryContributors
++ map (toXML g "category") entryCategories
++ map (toXML g "link") entryLinks
)
instance ToXML e (Source e) where
toXML g@XMLGen{..} tag Source{..} = xmlElem (xmlName atomNS tag) [] $
map xmlElemNode (
catMaybes
[ fmap (toXML g "id") sourceId
, fmap (toXML g "title") sourceTitle
, fmap (toXML g "updated") sourceUpdated
, fmap (toXML g "subtitle") sourceSubtitle
, fmap (toXML g "icon") sourceIcon
, fmap (toXML g "logo") sourceLogo
, fmap (toXML g "rights") sourceRights
, fmap (toXML g "generator") sourceGenerator
]
++ map (toXML g "author") sourceAuthors
++ map (toXML g "contributor") sourceContributors
++ map (toXML g "category") sourceCategories
++ map (toXML g "link") sourceLinks
)
instance ToXML e (Text e) where
toXML g@XMLGen{..} tag x = case x of
TextPlain c -> el [attr g "type" "text"] [xmlTextNode c]
TextHTML c -> el [attr g "type" "html"] [xmlTextNode c]
TextXHTML c -> el [attr g "type" "xhtml"] [xmlElemNode c]
where el = xmlElem (xmlName atomNS tag)
instance ToXML e (Content e) where
toXML g@XMLGen{..} tag x = case x of
InlinePlainContent t -> el [attr g "type" "text"] [xmlTextNode t]
InlineHTMLContent t -> el [attr g "type" "html"] [xmlTextNode t]
InlineXHTMLContent xml -> el [attr g "type" "xhtml"] [xmlElemNode xml]
InlineTextContent t mmedia -> el (mediaAttrs mmedia) [xmlTextNode t]
InlineXMLContent xml mmedia -> el (mediaAttrs mmedia) [xmlElemNode xml]
InlineBase64Content bs mmedia -> el (mediaAttrs mmedia) [xmlTextNode (T.decodeUtf8 $ B64.encode bs)]
OutOfLineContent uri mmedia -> el (mediaAttrs mmedia ++ [attr g "src" $ textShow uri]) []
where el = xmlElem (xmlName atomNS tag)
mediaAttrs = maybe [] (\m -> [media g m])
instance ToXML e Person where
toXML XMLGen{..} tag (Person name mu me) = xmlElem (xmlName atomNS tag) [] $
map xmlElemNode (catMaybes
[ Just $ el "name" [] [xmlTextNode name]
, fmap (\u -> el "uri" [] [xmlTextNode $ textShow u]) mu
, fmap (\(Email e) -> el "email" [] [xmlTextNode e]) me
])
where el n = xmlElem (xmlName atomNS n)
instance ToXML e Category where
toXML g@XMLGen{..} tag (Category term mscheme mlabel) = el attrs []
where el = xmlElem (xmlName atomNS tag)
attrs = catMaybes
[ Just (attr g "term" term)
, fmap (attr g "scheme" . textShow) mscheme
, fmap (attr g "label") mlabel
]
instance ToXML e Generator where
toXML g@XMLGen{..} tag (Generator name muri mversion) = el attrs [xmlTextNode name]
where el = xmlElem (xmlName atomNS tag)
attrs = catMaybes
[ fmap (attr g "uri" . textShow) muri
, fmap (attr g "version") mversion
]
instance ToXML e Link where
toXML g@XMLGen{..} tag (Link href mrel mmedia mlang mtitle mlen) = el attrs []
where el = xmlElem (xmlName atomNS tag)
attrs = catMaybes
[ Just . attr g "href" . textShow $ href
, fmap (attr g "rel" . textShow) mrel
, fmap (media g) mmedia
, fmap (\(LanguageTag lang) -> attr g "hreflang" lang) mlang
, fmap (attr g "title") mtitle
, fmap (attr g "length" . textShow) mlen
]
instance ToXML e URI where
toXML XMLGen{..} tag uri = xmlElem
(xmlName atomNS tag)
[]
[xmlTextNode (textShow uri)]
instance ToXML e UTCTime where
toXML XMLGen{..} tag utc = xmlElem
(xmlName atomNS tag)
[]
[xmlTextNode (T.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" utc)]