module Yesod.Sitemap
( sitemap
, sitemapList
, sitemapConduit
, robots
, SitemapUrl (..)
, SitemapChangeFreq (..)
) where
import Yesod.Core
import Data.Time (UTCTime)
import Text.XML.Stream.Render (renderBuilder)
import Data.Text (Text, pack)
import Data.XML.Types
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Default (def)
import qualified Data.Text as T
data SitemapChangeFreq = Always
| Hourly
| Daily
| Weekly
| Monthly
| Yearly
| Never
showFreq :: SitemapChangeFreq -> Text
showFreq Always = "always"
showFreq Hourly = "hourly"
showFreq Daily = "daily"
showFreq Weekly = "weekly"
showFreq Monthly = "monthly"
showFreq Yearly = "yearly"
showFreq Never = "never"
data SitemapUrl url = SitemapUrl
{ sitemapLoc :: url
, sitemapLastMod :: Maybe UTCTime
, sitemapChangeFreq :: Maybe SitemapChangeFreq
, sitemapPriority :: Maybe Double
}
robots :: MonadHandler m
=> Route (HandlerSite m)
-> m Text
robots smurl = do
ur <- getUrlRender
return $ T.unlines
[ "Sitemap: " `T.append` ur smurl
, "User-agent: *"
]
sitemap :: Source (HandlerT site IO) (SitemapUrl (Route site))
-> HandlerT site IO TypedContent
sitemap urls = do
render <- getUrlRender
respondSource typeXml $ do
yield Flush
urls $= sitemapConduit render $= renderBuilder def $= CL.map Chunk
sitemapList :: [SitemapUrl (Route site)] -> HandlerT site IO TypedContent
sitemapList = sitemap . mapM_ yield
sitemapConduit :: Monad m
=> (a -> Text)
-> Conduit (SitemapUrl a) m Event
sitemapConduit render = do
yield EventBeginDocument
element "urlset" [] $ awaitForever goUrl
yield EventEndDocument
where
namespace = "http://www.sitemaps.org/schemas/sitemap/0.9"
element name' attrs inside = do
yield $ EventBeginElement name attrs
() <- inside
yield $ EventEndElement name
where
name = Name name' (Just namespace) Nothing
goUrl SitemapUrl {..} = element "url" [] $ do
element "loc" [] $ yield $ EventContent $ ContentText $ render sitemapLoc
case sitemapLastMod of
Nothing -> return ()
Just lm -> element "lastmod" [] $ yield $ EventContent $ ContentText $ formatW3 lm
case sitemapChangeFreq of
Nothing -> return ()
Just scf -> element "changefreq" [] $ yield $ EventContent $ ContentText $ showFreq scf
case sitemapPriority of
Nothing -> return ()
Just p -> element "priority" [] $ yield $ EventContent $ ContentText $ pack $ show p