From 980cf466905732c592eb2a28fd38cd421371a785 Mon Sep 17 00:00:00 2001 From: Dan Burton Date: Mon, 23 Mar 2015 12:02:05 -0700 Subject: [PATCH 1/3] Add sitemap #20 --- Application.hs | 1 + Handler/Sitemap.hs | 91 +++++++++++++++++++++++++++++++++++++++++++ config/routes | 1 + stackage-server.cabal | 2 + 4 files changed, 95 insertions(+) create mode 100644 Handler/Sitemap.hs 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) From ad091514a7aef414bf49ae7a952257864652c095 Mon Sep 17 00:00:00 2001 From: Dan Burton Date: Mon, 23 Mar 2015 14:35:54 -0700 Subject: [PATCH 2/3] sitemap now streams from the database --- Handler/Sitemap.hs | 86 +++++++++++++++++++++++++++------------------- 1 file changed, 50 insertions(+), 36 deletions(-) diff --git a/Handler/Sitemap.hs b/Handler/Sitemap.hs index e5cc7ac..004dd56 100644 --- a/Handler/Sitemap.hs +++ b/Handler/Sitemap.hs @@ -2,10 +2,11 @@ module Handler.Sitemap (getSitemapR) where import Import import Yesod.Sitemap -import Data.List (nub) - -type Sitemap = Source Handler (SitemapUrl (Route App)) +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 @@ -24,54 +25,67 @@ getSitemapR = sitemap $ do url PackageCountsR - selectAll >>= ltsSitemaps - selectAll >>= mapM_ snapshotSitemap - selectAll >>= mapM_ packageMetadataSitemap - selectAll >>= mapM_ tagSitemap + runDBSource $ do + selectAll $= ltsSitemaps + selectAll $= snapshotSitemaps + selectAll $= packageMetadataSitemaps + selectAll $= tagSitemaps selectAll :: (PersistEntity val, PersistEntityBackend val ~ YesodPersistBackend App) - => ConduitM () (SitemapUrl (Route App)) Handler [val] -selectAll = lift $ runDB $ fmap (map entityVal) $ selectList [] [] + => Source (YesodDB App) val +selectAll = selectSource [] [] $= CL.map entityVal -ltsSitemaps :: [Lts] -> Sitemap -ltsSitemaps ltss = do - ltsMajorSitemap ltss - mapM_ ltsSitemap ltss +ltsSitemaps :: SitemapFor Lts +ltsSitemaps = sequenceConduits [ltsMajorSitemap, ltsSitemap] >> return () -ltsMajorSitemap :: [Lts] -> Sitemap -ltsMajorSitemap ltss = mapM_ go majorVersions +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 - majorVersions = nub $ map ltsMajor ltss go ver = priority 0.55 $ LtsR [pack (show ver)] -ltsSitemap :: Lts -> Sitemap -ltsSitemap lts = url $ LtsR [slug] +ltsSitemap :: SitemapFor Lts +ltsSitemap = awaitForever go where - slug = show' (ltsMajor lts) <> "." <> show' (ltsMinor lts) show' = pack . show + go lts = url $ LtsR [slug] + where + slug = show' (ltsMajor lts) <> "." <> show' (ltsMinor lts) -snapshotSitemap :: Stackage -> Sitemap -snapshotSitemap s = do - url' StackageHomeR - url' StackageMetadataR - url' StackageCabalConfigR - url' StackageIndexR - url' SnapshotPackagesR - url' DocsR - url' HoogleR +snapshotSitemaps :: SitemapFor Stackage +snapshotSitemaps = awaitForever go where - url' = url . SnapshotR (stackageSlug s) + go 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 +packageMetadataSitemaps :: SitemapFor Metadata +packageMetadataSitemaps = awaitForever go where - url' floc = url $ floc $ metadataName m + go m = do + url' PackageR + url' PackageSnapshotsR + where + url' floc = url $ floc $ metadataName m -tagSitemap :: Tag -> Sitemap -tagSitemap t = url $ TagR $ tagTag t +tagSitemaps :: SitemapFor Tag +tagSitemaps = awaitForever go + where + go t = url $ TagR $ tagTag t priority :: Double -> Route App -> Sitemap From 374d3733c052a436e9e469eb5753a6f4159387f8 Mon Sep 17 00:00:00 2001 From: Dan Burton Date: Mon, 23 Mar 2015 14:40:28 -0700 Subject: [PATCH 3/3] Add sitemap to robots.txt --- config/robots.txt | 1 + 1 file changed, 1 insertion(+) 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