125 lines
3.7 KiB
Haskell
125 lines
3.7 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
---------------------------------------------------------
|
|
--
|
|
-- Module : Yesod.Sitemap
|
|
-- Copyright : Michael Snoyman
|
|
-- License : BSD3
|
|
--
|
|
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
|
-- Stability : Stable
|
|
-- Portability : portable
|
|
--
|
|
-- Generating Google sitemap files.
|
|
--
|
|
---------------------------------------------------------
|
|
|
|
-- | Generates XML sitemap files.
|
|
--
|
|
-- See <http://www.sitemaps.org/>.
|
|
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
|
|
}
|
|
|
|
-- | A basic robots file which just lists the "Sitemap: " line.
|
|
robots :: MonadHandler m
|
|
=> Route (HandlerSite m) -- ^ sitemap url
|
|
-> m Text
|
|
robots smurl = do
|
|
ur <- getUrlRender
|
|
return $ T.unlines
|
|
[ "Sitemap: " `T.append` ur smurl
|
|
, "User-agent: *"
|
|
]
|
|
|
|
-- | Serve a stream of @SitemapUrl@s as a sitemap.
|
|
--
|
|
-- Since 1.2.0
|
|
sitemap :: ConduitT () (SitemapUrl (Route site)) (HandlerFor site) ()
|
|
-> HandlerFor site TypedContent
|
|
sitemap urls = do
|
|
render <- getUrlRender
|
|
respondSource typeXml $ do
|
|
yield Flush
|
|
urls .| sitemapConduit render .| renderBuilder def .| CL.map Chunk
|
|
|
|
-- | Convenience wrapper for @sitemap@ for the case when the input is an
|
|
-- in-memory list.
|
|
--
|
|
-- Since 1.2.0
|
|
sitemapList :: [SitemapUrl (Route site)] -> HandlerFor site TypedContent
|
|
sitemapList = sitemap . mapM_ yield
|
|
|
|
-- | Convert a stream of @SitemapUrl@s to XML @Event@s using the given URL
|
|
-- renderer.
|
|
--
|
|
-- This function is fully general for usage outside of Yesod.
|
|
--
|
|
-- Since 1.2.0
|
|
sitemapConduit :: Monad m
|
|
=> (a -> Text)
|
|
-> ConduitT (SitemapUrl a) Event m ()
|
|
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
|