diff --git a/Application.hs b/Application.hs index 53cb233..42c2e18 100644 --- a/Application.hs +++ b/Application.hs @@ -71,6 +71,7 @@ import Handler.UploadV2 import Handler.Hoogle import Handler.BuildVersion import Handler.PackageCounts +import Handler.Sitemap -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the diff --git a/Handler/Sitemap.hs b/Handler/Sitemap.hs new file mode 100644 index 0000000..004dd56 --- /dev/null +++ b/Handler/Sitemap.hs @@ -0,0 +1,105 @@ +module Handler.Sitemap (getSitemapR) where + +import Import +import Yesod.Sitemap +import qualified Data.Conduit.List as CL +import qualified Control.Monad.State as State + +type SitemapFor a = forall m. Monad m => Conduit a m (SitemapUrl (Route App)) +type Sitemap = forall m. Monad m => Producer m (SitemapUrl (Route App)) + +getSitemapR :: Handler TypedContent +getSitemapR = sitemap $ do + priority 1.0 $ HomeR + + priority 0.9 $ LtsR [] + priority 0.8 $ NightlyR [] + + priority 0.7 $ AllSnapshotsR + priority 0.7 $ PackageListR + + priority 0.6 $ TagListR + priority 0.6 $ AuthorsR + priority 0.6 $ InstallR + priority 0.6 $ OlderReleasesR + + url PackageCountsR + + runDBSource $ do + selectAll $= ltsSitemaps + selectAll $= snapshotSitemaps + selectAll $= packageMetadataSitemaps + selectAll $= tagSitemaps + + +selectAll :: (PersistEntity val, PersistEntityBackend val ~ YesodPersistBackend App) + => Source (YesodDB App) val +selectAll = selectSource [] [] $= CL.map entityVal + +ltsSitemaps :: SitemapFor Lts +ltsSitemaps = sequenceConduits [ltsMajorSitemap, ltsSitemap] >> return () + +clNub :: (Monad m, Eq a) => Conduit a m a +clNub = evalStateC [] $ awaitForever $ \a -> do + seen <- State.get + unless (a `elem` seen) $ do + State.put (a:seen) + yield a + +ltsMajorSitemap :: SitemapFor Lts +ltsMajorSitemap = CL.map ltsMajor =$= clNub =$= awaitForever go + where + go ver = priority 0.55 $ LtsR [pack (show ver)] + +ltsSitemap :: SitemapFor Lts +ltsSitemap = awaitForever go + where + show' = pack . show + go lts = url $ LtsR [slug] + where + slug = show' (ltsMajor lts) <> "." <> show' (ltsMinor lts) + +snapshotSitemaps :: SitemapFor Stackage +snapshotSitemaps = awaitForever go + where + go s = do + url' StackageHomeR + url' StackageMetadataR + url' StackageCabalConfigR + url' StackageIndexR + url' SnapshotPackagesR + url' DocsR + url' HoogleR + where + url' = url . SnapshotR (stackageSlug s) + +packageMetadataSitemaps :: SitemapFor Metadata +packageMetadataSitemaps = awaitForever go + where + go m = do + url' PackageR + url' PackageSnapshotsR + where + url' floc = url $ floc $ metadataName m + +tagSitemaps :: SitemapFor Tag +tagSitemaps = awaitForever go + where + go t = url $ TagR $ tagTag t + + +priority :: Double -> Route App -> Sitemap +priority p loc = yield $ SitemapUrl + { sitemapLoc = loc + , sitemapLastMod = Nothing + , sitemapChangeFreq = Nothing + , sitemapPriority = Just p + } + +url :: Route App -> Sitemap +url loc = yield $ SitemapUrl + { sitemapLoc = loc + , sitemapLastMod = Nothing + , sitemapChangeFreq = Nothing + , sitemapPriority = Nothing + } diff --git a/config/robots.txt b/config/robots.txt index f10713e..f594075 100644 --- a/config/robots.txt +++ b/config/robots.txt @@ -1,2 +1,3 @@ User-agent: * Disallow: /haddock/ +Sitemap: /sitemap.xml diff --git a/config/routes b/config/routes index 76f35b5..a055031 100644 --- a/config/routes +++ b/config/routes @@ -4,6 +4,7 @@ /favicon.ico FaviconR GET /robots.txt RobotsR GET +/sitemap.xml SitemapR GET / HomeR GET /snapshots AllSnapshotsR GET diff --git a/stackage-server.cabal b/stackage-server.cabal index 5a1b6f3..6e48634 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -52,6 +52,7 @@ library Handler.UploadV2 Handler.BuildVersion Handler.PackageCounts + Handler.Sitemap if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT @@ -163,6 +164,7 @@ library , deepseq-generics , auto-update , stackage-types + , yesod-sitemap executable stackage-server if flag(library-only)