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

Clean up Sitemap a bit

Browse Source
This commit is contained in:
Michael Snoyman 2015-05-14 16:14:31 +03:00
parent d35b73d67f
commit 27deb7b378
1 changed files with 15 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
Handler/Sitemap.hs
View File

@ -3,21 +3,19 @@ module Handler.Sitemap (getSitemapR) where
import Import import Import
import Yesod.Sitemap import Yesod.Sitemap
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import qualified Control.Monad.State as State import Stackage.Database
type SitemapFor a = forall m. Monad m => Conduit a m (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)) type Sitemap = forall m. Monad m => Producer m (SitemapUrl (Route App))
getSitemapR :: Handler TypedContent getSitemapR :: Handler TypedContent
getSitemapR = sitemap $ do getSitemapR = sitemap $ do
error "getSitemapR"
{- FIXME
priority 1.0 $ HomeR priority 1.0 $ HomeR
priority 0.9 $ LtsR [] priority 0.9 $ OldLtsR []
-- TODO: uncomment when this is presentable -- TODO: uncomment when this is presentable
--priority 0.9 $ DownloadR --priority 0.9 $ DownloadR
priority 0.8 $ NightlyR [] priority 0.8 $ OldNightlyR []
priority 0.7 $ AllSnapshotsR priority 0.7 $ AllSnapshotsR
priority 0.7 $ PackageListR priority 0.7 $ PackageListR
@ -27,12 +25,10 @@ getSitemapR = sitemap $ do
priority 0.6 $ InstallR priority 0.6 $ InstallR
priority 0.6 $ OlderReleasesR priority 0.6 $ OlderReleasesR
url PackageCountsR
runDBSource $ do runDBSource $ do
selectAll $= ltsSitemaps --selectAll $= ltsSitemaps
selectAll $= snapshotSitemaps return () $= snapshotSitemaps -- FIXME
selectAll $= packageMetadataSitemaps return () $= packageMetadataSitemaps -- FIXME
selectAll $= tagSitemaps selectAll $= tagSitemaps
@ -40,9 +36,7 @@ selectAll :: (PersistEntity val, PersistEntityBackend val ~ YesodPersistBackend
=> Source (YesodDB App) val => Source (YesodDB App) val
selectAll = selectSource [] [] $= CL.map entityVal selectAll = selectSource [] [] $= CL.map entityVal
ltsSitemaps :: SitemapFor Lts {- FIXME
ltsSitemaps = sequenceConduits [ltsMajorSitemap, ltsSitemap] >> return ()
clNub :: (Monad m, Eq a) => Conduit a m a clNub :: (Monad m, Eq a) => Conduit a m a
clNub = evalStateC [] $ awaitForever $ \a -> do clNub = evalStateC [] $ awaitForever $ \a -> do
seen <- State.get seen <- State.get
@ -50,6 +44,9 @@ clNub = evalStateC [] $ awaitForever $ \a -> do
State.put (a:seen) State.put (a:seen)
yield a yield a
ltsSitemaps :: SitemapFor Lts
ltsSitemaps = sequenceConduits [ltsMajorSitemap, ltsSitemap] >> return ()
ltsMajorSitemap :: SitemapFor Lts ltsMajorSitemap :: SitemapFor Lts
ltsMajorSitemap = CL.map ltsMajor =$= clNub =$= awaitForever go ltsMajorSitemap = CL.map ltsMajor =$= clNub =$= awaitForever go
where where
@ -62,29 +59,29 @@ ltsSitemap = awaitForever go
go lts = url $ LtsR [slug] go lts = url $ LtsR [slug]
where where
slug = show' (ltsMajor lts) <> "." <> show' (ltsMinor lts) slug = show' (ltsMajor lts) <> "." <> show' (ltsMinor lts)
-}
snapshotSitemaps :: SitemapFor Stackage snapshotSitemaps :: SitemapFor Snapshot
snapshotSitemaps = awaitForever go snapshotSitemaps = awaitForever go
where where
go s = do go s = do
url' StackageHomeR url' StackageHomeR
url' StackageMetadataR
url' StackageCabalConfigR url' StackageCabalConfigR
url' StackageIndexR url' StackageIndexR
url' SnapshotPackagesR url' SnapshotPackagesR
url' DocsR url' DocsR
url' HoogleR url' HoogleR
where where
url' = url . SnapshotR (stackageSlug s) url' = url . SnapshotR (snapshotName s)
packageMetadataSitemaps :: SitemapFor Metadata packageMetadataSitemaps :: SitemapFor Package
packageMetadataSitemaps = awaitForever go packageMetadataSitemaps = awaitForever go
where where
go m = do go m = do
url' PackageR url' PackageR
url' PackageSnapshotsR url' PackageSnapshotsR
where where
url' floc = url $ floc $ metadataName m url' floc = url $ floc $ PackageName $ packageName m
tagSitemaps :: SitemapFor Tag tagSitemaps :: SitemapFor Tag
tagSitemaps = awaitForever go tagSitemaps = awaitForever go
@ -107,4 +104,3 @@ url loc = yield $ SitemapUrl
, sitemapChangeFreq = Nothing , sitemapChangeFreq = Nothing
, sitemapPriority = Nothing , sitemapPriority = Nothing
} }
-}