haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-02-07 16:47:27 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

sitemap now streams from the database

Browse Source
This commit is contained in:
Dan Burton 2015-03-23 14:35:54 -07:00
parent 980cf46690
commit ad091514a7
1 changed files with 50 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
Handler/Sitemap.hs
View File

@ -2,10 +2,11 @@ module Handler.Sitemap (getSitemapR) where
import Import import Import
import Yesod.Sitemap import Yesod.Sitemap
import Data.List (nub) import qualified Data.Conduit.List as CL
import qualified Control.Monad.State as State
type Sitemap = Source Handler (SitemapUrl (Route App))
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 :: Handler TypedContent
getSitemapR = sitemap $ do getSitemapR = sitemap $ do
@ -24,54 +25,67 @@ getSitemapR = sitemap $ do
url PackageCountsR url PackageCountsR
selectAll >>= ltsSitemaps runDBSource $ do
selectAll >>= mapM_ snapshotSitemap selectAll $= ltsSitemaps
selectAll >>= mapM_ packageMetadataSitemap selectAll $= snapshotSitemaps
selectAll >>= mapM_ tagSitemap selectAll $= packageMetadataSitemaps
selectAll $= tagSitemaps
selectAll :: (PersistEntity val, PersistEntityBackend val ~ YesodPersistBackend App) selectAll :: (PersistEntity val, PersistEntityBackend val ~ YesodPersistBackend App)
=> ConduitM () (SitemapUrl (Route App)) Handler [val] => Source (YesodDB App) val
selectAll = lift $ runDB $ fmap (map entityVal) $ selectList [] [] selectAll = selectSource [] [] $= CL.map entityVal
ltsSitemaps :: [Lts] -> Sitemap ltsSitemaps :: SitemapFor Lts
ltsSitemaps ltss = do ltsSitemaps = sequenceConduits [ltsMajorSitemap, ltsSitemap] >> return ()
ltsMajorSitemap ltss
mapM_ ltsSitemap ltss
ltsMajorSitemap :: [Lts] -> Sitemap clNub :: (Monad m, Eq a) => Conduit a m a
ltsMajorSitemap ltss = mapM_ go majorVersions 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 where
majorVersions = nub $ map ltsMajor ltss
go ver = priority 0.55 $ LtsR [pack (show ver)] go ver = priority 0.55 $ LtsR [pack (show ver)]
ltsSitemap :: Lts -> Sitemap ltsSitemap :: SitemapFor Lts
ltsSitemap lts = url $ LtsR [slug] ltsSitemap = awaitForever go
where where
slug = show' (ltsMajor lts) <> "." <> show' (ltsMinor lts)
show' = pack . show show' = pack . show
go lts = url $ LtsR [slug]
where
slug = show' (ltsMajor lts) <> "." <> show' (ltsMinor lts)
snapshotSitemap :: Stackage -> Sitemap snapshotSitemaps :: SitemapFor Stackage
snapshotSitemap s = do snapshotSitemaps = awaitForever go
url' StackageHomeR
url' StackageMetadataR
url' StackageCabalConfigR
url' StackageIndexR
url' SnapshotPackagesR
url' DocsR
url' HoogleR
where 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 packageMetadataSitemaps :: SitemapFor Metadata
packageMetadataSitemap m = do packageMetadataSitemaps = awaitForever go
url' PackageR
url' PackageSnapshotsR
where where
url' floc = url $ floc $ metadataName m go m = do
url' PackageR
url' PackageSnapshotsR
where
url' floc = url $ floc $ metadataName m
tagSitemap :: Tag -> Sitemap tagSitemaps :: SitemapFor Tag
tagSitemap t = url $ TagR $ tagTag t tagSitemaps = awaitForever go
where
go t = url $ TagR $ tagTag t
priority :: Double -> Route App -> Sitemap priority :: Double -> Route App -> Sitemap