AtomFeed.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
---------------------------------------------------------
--
-- Module        : Yesod.Helpers.AtomFeed
-- Copyright     : Michael Snoyman
-- License       : BSD3
--
-- Maintainer    : Michael Snoyman <michael@snoyman.com>
-- Stability     : Stable
-- Portability   : portable
--
-- Generating atom news feeds.
--
---------------------------------------------------------

module Yesod.Helpers.AtomFeed
    ( AtomFeed (..)
    , AtomFeedEntry (..)
    , AtomFeedResponse (..)
    , atomFeed
    ) where

import Yesod
import Data.Time.Clock (UTCTime)
import Web.Encodings (formatW3)

data AtomFeedResponse = AtomFeedResponse AtomFeed Approot

atomFeed :: YesodApproot y => AtomFeed -> Handler y AtomFeedResponse
atomFeed f = do
    y <- getYesod
    return $ AtomFeedResponse f $ approot y

data AtomFeed = AtomFeed
    { atomTitle :: String
    , atomLinkSelf :: Location
    , atomLinkHome :: Location
    , atomUpdated :: UTCTime
    , atomEntries :: [AtomFeedEntry]
    }
instance HasReps AtomFeedResponse where
    chooseRep = defChooseRep
        [ (TypeAtom, return . cs)
        ]

data AtomFeedEntry = AtomFeedEntry
    { atomEntryLink :: Location
    , atomEntryUpdated :: UTCTime
    , atomEntryTitle :: String
    , atomEntryContent :: Html
    }

instance ConvertSuccess AtomFeedResponse Content where
    convertSuccess = cs . (cs :: Html -> XmlDoc) . cs
instance ConvertSuccess AtomFeedResponse Html where
    convertSuccess (AtomFeedResponse f ar) =
        Tag "feed" [("xmlns", "http://www.w3.org/2005/Atom")] $ HtmlList
          [ Tag "title" [] $ cs $ atomTitle f
          , EmptyTag "link" [ ("rel", "self")
                            , ("href", showLocation ar $ atomLinkSelf f)
                            ]
          , EmptyTag "link" [ ("href", showLocation ar $ atomLinkHome f)
                            ]
          , Tag "updated" [] $ cs $ formatW3 $ atomUpdated f
          , Tag "id" [] $ cs $ showLocation ar $ atomLinkHome f
          , HtmlList $ map cs $ zip (atomEntries f) $ repeat ar
        ]

instance ConvertSuccess (AtomFeedEntry, Approot) Html where
    convertSuccess (e, ar) = Tag "entry" [] $ HtmlList
        [ Tag "id" [] $ cs $ showLocation ar $ atomEntryLink e
        , EmptyTag "link" [("href", showLocation ar $ atomEntryLink e)]
        , Tag "updated" [] $ cs $ formatW3 $ atomEntryUpdated e
        , Tag "title" [] $ cs $ atomEntryTitle e
        , Tag "content" [("type", "html")] $ cdata $ atomEntryContent e
        ]