{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- | __Dublin Core__ extension for RSS. -- Cf specification at . module Text.RSS.Extensions.DublinCore ( DublinCoreModule(..) , RssChannelExtension(..) , RssItemExtension(..) , DcMetaData(..) , mkDcMetaData ) where -- {{{ Imports import Text.RSS.Extensions import Text.RSS.Types import Conduit import Control.Exception.Safe as Exception import Control.Monad import Control.Monad.Fix import Data.Maybe import Data.Text (Text) import qualified Data.Text as Text import Data.Time.Clock import Data.Time.LocalTime import Data.Time.RFC3339 import Data.XML.Types import GHC.Generics import Lens.Micro import Lens.Micro.TH import qualified Text.XML.DublinCore.Conduit.Parse as DC import Text.XML.DublinCore.Conduit.Render import Text.XML.Stream.Parse import URI.ByteString -- }}} -- {{{ Utils projectC :: Monad m => Traversal' a b -> ConduitT a b m () projectC prism = fix $ \recurse -> do item <- await case (item, item ^? (_Just . prism)) of (_, Just a) -> yield a >> recurse (Just _, _) -> recurse _ -> return () -- }}} -- | __Dublin Core__ extension model. data DcMetaData = DcMetaData { elementContributor :: Text , elementCoverage :: Text , elementCreator :: Text , elementDate :: Maybe UTCTime , elementDescription :: Text , elementFormat :: Text , elementIdentifier :: Text , elementLanguage :: Text , elementPublisher :: Text , elementRelation :: Text , elementRights :: Text , elementSource :: Text , elementSubject :: Text , elementTitle :: Text , elementType :: Text } deriving(Eq, Generic, Ord, Read, Show) -- | Construct an empty 'DcMetaData'. mkDcMetaData = DcMetaData mempty mempty mempty Nothing mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty data ElementPiece = ElementContributor { __elementContributor :: Text } | ElementCoverage { __elementCoverage :: Text } | ElementCreator { __elementCreator :: Text } | ElementDate { __elementDate :: UTCTime } | ElementDescription { __elementDescription :: Text } | ElementFormat { __elementFormat :: Text } | ElementIdentifier { __elementIdentifier :: Text } | ElementLanguage { __elementLanguage :: Text } | ElementPublisher { __elementPublisher :: Text } | ElementRelation { __elementRelation :: Text } | ElementRights { __elementRights :: Text } | ElementSource { __elementSource :: Text } | ElementSubject { __elementSubject :: Text } | ElementTitle { __elementTitle :: Text } | ElementType { __elementType :: Text } makeLenses ''ElementPiece -- | Parse a set of Dublin Core metadata elements. dcMetadata :: MonadThrow m => ConduitT Event o m DcMetaData dcMetadata = manyYield' (choose piece) .| parser where parser = getZipConduit $ DcMetaData <$> ZipConduit (projectC _elementContributor .| headDefC "") <*> ZipConduit (projectC _elementCoverage .| headDefC "") <*> ZipConduit (projectC _elementCreator .| headDefC "") <*> ZipConduit (projectC _elementDate .| headC) <*> ZipConduit (projectC _elementDescription .| headDefC "") <*> ZipConduit (projectC _elementFormat .| headDefC "") <*> ZipConduit (projectC _elementIdentifier .| headDefC "") <*> ZipConduit (projectC _elementLanguage .| headDefC "") <*> ZipConduit (projectC _elementPublisher .| headDefC "") <*> ZipConduit (projectC _elementRelation .| headDefC "") <*> ZipConduit (projectC _elementRights .| headDefC "") <*> ZipConduit (projectC _elementSource .| headDefC "") <*> ZipConduit (projectC _elementSubject .| headDefC "") <*> ZipConduit (projectC _elementTitle .| headDefC "") <*> ZipConduit (projectC _elementType .| headDefC "") piece = [ fmap ElementContributor <$> DC.elementContributor , fmap ElementCoverage <$> DC.elementCoverage , fmap ElementCreator <$> DC.elementCreator , fmap ElementDate <$> DC.elementDate , fmap ElementDescription <$> DC.elementDescription , fmap ElementFormat <$> DC.elementFormat , fmap ElementIdentifier <$> DC.elementIdentifier , fmap ElementLanguage <$> DC.elementLanguage , fmap ElementPublisher <$> DC.elementPublisher , fmap ElementRelation <$> DC.elementRelation , fmap ElementRights <$> DC.elementRights , fmap ElementSource <$> DC.elementSource , fmap ElementSubject <$> DC.elementSubject , fmap ElementTitle <$> DC.elementTitle , fmap ElementType <$> DC.elementType ] -- | Render a set of Dublin Core metadata elements. renderDcMetadata :: Monad m => DcMetaData -> ConduitT () Event m () renderDcMetadata DcMetaData{..} = do unless (Text.null elementContributor) $ renderElementContributor elementContributor unless (Text.null elementCoverage) $ renderElementCoverage elementCoverage unless (Text.null elementCreator) $ renderElementCreator elementCreator forM_ elementDate renderElementDate unless (Text.null elementDescription) $ renderElementDescription elementDescription unless (Text.null elementFormat) $ renderElementFormat elementFormat unless (Text.null elementIdentifier) $ renderElementIdentifier elementIdentifier unless (Text.null elementLanguage) $ renderElementLanguage elementLanguage unless (Text.null elementPublisher) $ renderElementPublisher elementPublisher unless (Text.null elementRelation) $ renderElementRelation elementRelation unless (Text.null elementRights) $ renderElementRights elementRights unless (Text.null elementSource) $ renderElementSource elementSource unless (Text.null elementSubject) $ renderElementSubject elementSubject unless (Text.null elementTitle) $ renderElementTitle elementTitle unless (Text.null elementType) $ renderElementType elementType -- | __Dublin Core__ tag type. newtype DublinCoreModule a = DublinCoreModule a instance ParseRssExtension a => ParseRssExtension (DublinCoreModule a) where parseRssChannelExtension = getZipConduit $ DublinCoreChannel <$> ZipConduit dcMetadata <*> ZipConduit parseRssChannelExtension parseRssItemExtension = getZipConduit $ DublinCoreItem <$> ZipConduit dcMetadata <*> ZipConduit parseRssItemExtension instance RenderRssExtension a => RenderRssExtension (DublinCoreModule a) where renderRssChannelExtension DublinCoreChannel{..} = do renderDcMetadata channelDcMetaData renderRssChannelExtension channelDcOther renderRssItemExtension DublinCoreItem{..} = do renderDcMetadata itemDcMetaData renderRssItemExtension itemDcOther data instance RssChannelExtension (DublinCoreModule a) = DublinCoreChannel { channelDcMetaData :: DcMetaData , channelDcOther :: RssChannelExtension a } deriving instance Eq (RssChannelExtension a) => Eq (RssChannelExtension (DublinCoreModule a)) deriving instance Ord (RssChannelExtension a) => Ord (RssChannelExtension (DublinCoreModule a)) deriving instance Read (RssChannelExtension a) => Read (RssChannelExtension (DublinCoreModule a)) deriving instance Show (RssChannelExtension a) => Show (RssChannelExtension (DublinCoreModule a)) deriving instance Generic (RssChannelExtension a) => Generic (RssChannelExtension (DublinCoreModule a)) data instance RssItemExtension (DublinCoreModule a) = DublinCoreItem { itemDcMetaData :: DcMetaData , itemDcOther :: RssItemExtension a } deriving instance Eq (RssItemExtension a) => Eq (RssItemExtension (DublinCoreModule a)) deriving instance Ord (RssItemExtension a) => Ord (RssItemExtension (DublinCoreModule a)) deriving instance Read (RssItemExtension a) => Read (RssItemExtension (DublinCoreModule a)) deriving instance Show (RssItemExtension a) => Show (RssItemExtension (DublinCoreModule a)) deriving instance Generic (RssItemExtension a) => Generic (RssItemExtension (DublinCoreModule a))