diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Carl Baatz + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Carl Baatz nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/atom-basic.cabal b/atom-basic.cabal new file mode 100644 --- /dev/null +++ b/atom-basic.cabal @@ -0,0 +1,39 @@ +name: atom-basic +version: 0.0.1.0 +synopsis: Basic Atom feed construction +description: + + This library provides a type for an Atom feed + (http://tools.ietf.org/html/rfc4287) and a way to produce its XML. XML is + constructed with the help of a record of construction functions (`XMLGen`) + that you provide. This allows you to easily use this with the XML library + of your choice. + +license: BSD3 +license-file: LICENSE +author: Carl Baatz +maintainer: carl.baatz@gmail.com +copyright: (c) 2015 Carl Baatz +category: Web +build-type: Simple +cabal-version: >=1.10 + +flag network-uri + description: Get Network.URI from the network-uri package + default: True + +library + exposed-modules: Web.Atom + ghc-options: -Wall + hs-source-dirs: src + default-language: Haskell2010 + if flag(network-uri) + build-depends: network-uri >= 2.6, network >= 2.6 + else + build-depends: network-uri < 2.6, network < 2.6 + build-depends: base >=4.7 && <5 + , text + , time + , old-locale + , bytestring + , base64-bytestring diff --git a/src/Web/Atom.hs b/src/Web/Atom.hs new file mode 100644 --- /dev/null +++ b/src/Web/Atom.hs @@ -0,0 +1,354 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Web.Atom + ( makeFeed + , makeEntry + , feedXML + , entryXML + , XMLGen (..) + , Feed(..) + , Entry(..) + , Source(..) + , Content(..) + , Category(..) + , Generator(..) + , Person(..) + , Email(..) + , Rel(..) + , Text(..) + , Link(..) + , LanguageTag(..) + , MediaType(..) + , UTCTime + , URI(..) + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BC +import Data.Maybe (catMaybes) +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 (..)) +import System.Locale (defaultTimeLocale) + +-- ------------------------ +-- Convenience constructors +-- ------------------------ + +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 = [] + } + +-- ------------------------- +-- External XML construction +-- ------------------------- + +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 + } + +-- ---------- +-- Atom Types +-- ---------- + +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] -- At least one unless all child entries have at least one author + , 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] -- At least one unless all child entries have at least one author + , 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] -- At least one unless source child contains author or parent contains author + , entryContributors :: [Person] + , entryCategories :: [Category] + , entryLinks :: [Link] -- Required if no content element + } deriving (Show, Eq) + +-- ------------------------- +-- Internal helper functions +-- ------------------------- + +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 + +-- ------------------------- +-- Internal XML construction +-- ------------------------- + +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)]