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..e5cc7ac --- /dev/null +++ b/Handler/Sitemap.hs @@ -0,0 +1,91 @@ +module Handler.Sitemap (getSitemapR) where + +import Import +import Yesod.Sitemap +import Data.List (nub) + +type Sitemap = Source Handler (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 + + selectAll >>= ltsSitemaps + selectAll >>= mapM_ snapshotSitemap + selectAll >>= mapM_ packageMetadataSitemap + selectAll >>= mapM_ tagSitemap + + +selectAll :: (PersistEntity val, PersistEntityBackend val ~ YesodPersistBackend App) + => ConduitM () (SitemapUrl (Route App)) Handler [val] +selectAll = lift $ runDB $ fmap (map entityVal) $ selectList [] [] + +ltsSitemaps :: [Lts] -> Sitemap +ltsSitemaps ltss = do + ltsMajorSitemap ltss + mapM_ ltsSitemap ltss + +ltsMajorSitemap :: [Lts] -> Sitemap +ltsMajorSitemap ltss = mapM_ go majorVersions + where + majorVersions = nub $ map ltsMajor ltss + go ver = priority 0.55 $ LtsR [pack (show ver)] + +ltsSitemap :: Lts -> Sitemap +ltsSitemap lts = url $ LtsR [slug] + where + slug = show' (ltsMajor lts) <> "." <> show' (ltsMinor lts) + show' = pack . show + +snapshotSitemap :: Stackage -> Sitemap +snapshotSitemap s = do + url' StackageHomeR + url' StackageMetadataR + url' StackageCabalConfigR + url' StackageIndexR + url' SnapshotPackagesR + url' DocsR + url' HoogleR + where + url' = url . SnapshotR (stackageSlug s) + +packageMetadataSitemap :: Metadata -> Sitemap +packageMetadataSitemap m = do + url' PackageR + url' PackageSnapshotsR + where + url' floc = url $ floc $ metadataName m + +tagSitemap :: Tag -> Sitemap +tagSitemap 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/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)