Divide sitemap into parts

Author: AliasQli

src/Distribution/Server/Features/Sitemap.hs

@@ -25,7 +25,21 @@ import Data.ByteString.Lazy (ByteString)
 import Data.Time.Clock (UTCTime(..), getCurrentTime)
 import Data.Time.Calendar (showGregorian)
 import Network.URI
+import Control.DeepSeq
+import Text.Read
+import Data.List.Split
 
+data Sitemap
+  = Sitemap 
+    { sitemapIndex :: XMLResponse
+    , sitemaps     :: [XMLResponse]
+    }
+
+instance NFData Sitemap where
+  rnf (Sitemap i s) = rnf i `seq` rnf s
+
+instance MemSize Sitemap where
+  memSize (Sitemap i s) = memSize2 i s
 
 data SitemapFeature = SitemapFeature {
   sitemapFeatureInterface :: HackageFeature
@@ -67,8 +81,8 @@ sitemapFeature  :: ServerEnv
                 -> DocumentationFeature
                 -> TagsFeature
                 -> UTCTime
-                -> AsyncCache XMLResponse
-                -> (SitemapFeature, IO XMLResponse)
+                -> AsyncCache Sitemap
+                -> (SitemapFeature, IO Sitemap)
 sitemapFeature  ServerEnv{..}
                 CoreFeature{..}
                 DocumentationFeature{..}
@@ -79,50 +93,70 @@ sitemapFeature  ServerEnv{..}
   where
 
     sitemapFeatureInterface = (emptyHackageFeature "sitemap") {
-      featureResources  = [ xmlSitemapResource ]
+      featureResources  = [ xmlSitemapIndexResource, xmlSitemapResource ]
       , featureState    = []
-      , featureDesc     = "Provides a sitemap.xml for search engines"
+      , featureDesc     = "Provides sitemap for search engines"
       , featureCaches   =
           [ CacheComponent {
-              cacheDesc       = "sitemap.xml",
+              cacheDesc       = "sitemap",
               getCacheMemSize = memSize <$> readAsyncCache sitemapCache
             }
           ]
       , featurePostInit = do
           syncAsyncCache sitemapCache
           addCronJob serverCron CronJob {
-            cronJobName      = "regenerate the cached sitemap.xml",
+            cronJobName      = "regenerate the cached sitemap",
             cronJobFrequency = DailyJobFrequency,
             cronJobOneShot   = False,
             cronJobAction    = prodAsyncCache sitemapCache "cron"
           }
     }
 
+    xmlSitemapIndexResource :: Resource
+    xmlSitemapIndexResource = (resourceAt "/sitemap_index.xml") {
+      resourceDesc = [(GET, "The dynamically generated sitemap index, in XML format")]
+    , resourceGet = [("xml", serveSitemapIndex)]
+    }
+
     xmlSitemapResource :: Resource
-    xmlSitemapResource = (resourceAt "/sitemap.xml") {
+    xmlSitemapResource = (resourceAt "/sitemap/:filename") {
       resourceDesc = [(GET, "The dynamically generated sitemap, in XML format")]
     , resourceGet = [("xml", serveSitemap)]
     }
 
-    serveSitemap :: DynamicPath -> ServerPartE Response
-    serveSitemap _ = do
-      sitemapXML <- liftIO $ readAsyncCache sitemapCache
+    serveSitemapIndex :: DynamicPath -> ServerPartE Response
+    serveSitemapIndex _ = do
+      Sitemap{..} <- liftIO $ readAsyncCache sitemapCache
       cacheControlWithoutETag [Public, maxAgeDays 1]
-      return (toResponse sitemapXML)
+      return (toResponse sitemapIndex)
+
+    serveSitemap :: DynamicPath -> ServerPartE Response
+    serveSitemap dpath =
+      case lookup "filename" dpath of
+        Just filename
+          | [basename, "xml"] <- splitOn "." filename
+          , Just i <- readMaybe basename -> do
+              Sitemap{..} <- liftIO $ readAsyncCache sitemapCache
+              guard (i < length sitemaps)
+              cacheControlWithoutETag [Public, maxAgeDays 1]
+              return (toResponse (sitemaps !! i))
+        _ -> mzero
 
     -- Generates a list of sitemap entries corresponding to hackage pages, then
     -- builds and returns an XML sitemap.
-    updateSitemapCache :: IO XMLResponse
+    updateSitemapCache :: IO Sitemap
     updateSitemapCache = do
 
       alltags  <- queryGetTagList
       pkgIndex <- queryGetPackageIndex
       docIndex <- queryDocumentationIndex
 
-      let sitemap = generateSitemap serverBaseURI pageBuildDate
+      let sitemaps = generateSitemap serverBaseURI pageBuildDate
                                     (map fst alltags)
                                     pkgIndex docIndex
-      return (XMLResponse sitemap)
+          uriScheme i = "/sitemap/" <> show i <> ".xml"
+          sitemapIndex = renderSitemapIndex serverBaseURI (map uriScheme [0..(length sitemaps - 1)])
+      return $ Sitemap (XMLResponse sitemapIndex) (map XMLResponse sitemaps)
 
     pageBuildDate :: T.Text
     pageBuildDate = T.pack (showGregorian (utctDay initTime))
@@ -132,9 +166,9 @@ generateSitemap :: URI
                 -> [Tag]
                 -> PackageIndex.PackageIndex PkgInfo
                 -> Map.Map PackageId a
-                -> ByteString
+                -> [ByteString]
 generateSitemap serverBaseURI pageBuildDate alltags pkgIndex docIndex =
-    renderSitemap serverBaseURI allEntries
+    renderSitemap serverBaseURI <$> chunksOf 50000 allEntries
   where
     -- Combine and build sitemap
     allEntries = miscEntries

src/Distribution/Server/Features/Sitemap/Functions.hs

@@ -23,6 +23,7 @@
 module Distribution.Server.Features.Sitemap.Functions (
     SitemapEntry
   , ChangeFreq(..)
+  , renderSitemapIndex
   , renderSitemap
   , urlsToSitemapEntries
   , pathsAndDatesToSitemapEntries
@@ -47,6 +48,22 @@ data SitemapEntry = SitemapEntry {
 
 data ChangeFreq = Monthly | Weekly | Daily
 
+-- | Generate a sitemap index file from each sitemap uri.
+renderSitemapIndex :: URI -> [String] -> ByteString
+renderSitemapIndex serverBaseURI sitemaps =
+  xrender $
+    doc defaultDocInfo $
+      xelem "sitemapindex" $
+          xattr "xmlns" "http://www.sitemaps.org/schemas/sitemap/0.9"
+        <#> map renderLink sitemaps
+  where
+    serverBaseURI' = T.pack (show serverBaseURI)
+    renderLink :: String -> Xml Elem
+    renderLink uri = xelem "sitemap" $ 
+      xelems [
+        xelem "loc" (xtext (serverBaseURI' <> T.pack (uri)))
+      ]
+
 -- | Primary function - generates the XML file from a list of Nodes.
 renderSitemap :: URI -> [SitemapEntry] -> ByteString
 renderSitemap serverBaseURI entries =