Add sitemap #20

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

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
+    }

config/routes

@@ -4,6 +4,7 @@
 
 /favicon.ico FaviconR GET
 /robots.txt RobotsR GET
+/sitemap.xml SitemapR GET
 
 / HomeR GET
 /snapshots AllSnapshotsR GET

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)