mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-11 19:58:28 +01:00
768eaec573
Motivation: these were the last things requiring a database. Once this is gone, it simplifies deployment dramatically. I'm also not sure that the social features were really worth keeping.
100 lines
2.6 KiB
Haskell
100 lines
2.6 KiB
Haskell
module Handler.Sitemap (getSitemapR) where
|
|
|
|
import Import
|
|
import Yesod.Sitemap
|
|
import qualified Data.Conduit.List as CL
|
|
import Stackage.Database
|
|
|
|
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
|
|
priority 1.0 $ HomeR
|
|
|
|
priority 0.9 $ OldLtsR []
|
|
-- TODO: uncomment when this is presentable
|
|
--priority 0.9 $ DownloadR
|
|
priority 0.8 $ OldNightlyR []
|
|
|
|
priority 0.7 $ AllSnapshotsR
|
|
priority 0.7 $ PackageListR
|
|
|
|
priority 0.6 $ AuthorsR
|
|
priority 0.6 $ InstallR
|
|
priority 0.6 $ OlderReleasesR
|
|
|
|
{- FIXME
|
|
runDBSource $ do
|
|
--selectAll $= ltsSitemaps
|
|
return () $= snapshotSitemaps -- FIXME
|
|
return () $= packageMetadataSitemaps -- FIXME
|
|
|
|
|
|
selectAll :: (PersistEntity val, PersistEntityBackend val ~ YesodPersistBackend App)
|
|
=> Source (YesodDB App) val
|
|
selectAll = selectSource [] [] $= CL.map entityVal
|
|
|
|
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
|
|
|
|
ltsSitemaps :: SitemapFor Lts
|
|
ltsSitemaps = sequenceConduits [ltsMajorSitemap, ltsSitemap] >> return ()
|
|
|
|
ltsMajorSitemap :: SitemapFor Lts
|
|
ltsMajorSitemap = CL.map ltsMajor =$= clNub =$= awaitForever go
|
|
where
|
|
go ver = priority 0.55 $ LtsR [pack (show ver)]
|
|
|
|
ltsSitemap :: SitemapFor Lts
|
|
ltsSitemap = awaitForever go
|
|
where
|
|
show' = pack . show
|
|
go lts = url $ LtsR [slug]
|
|
where
|
|
slug = show' (ltsMajor lts) <> "." <> show' (ltsMinor lts)
|
|
-}
|
|
|
|
snapshotSitemaps :: SitemapFor Snapshot
|
|
snapshotSitemaps = awaitForever go
|
|
where
|
|
go s = do
|
|
url' StackageHomeR
|
|
url' StackageCabalConfigR
|
|
url' StackageIndexR
|
|
url' SnapshotPackagesR
|
|
url' DocsR
|
|
url' HoogleR
|
|
where
|
|
url' = url . SnapshotR (snapshotName s)
|
|
|
|
packageMetadataSitemaps :: SitemapFor Package
|
|
packageMetadataSitemaps = awaitForever go
|
|
where
|
|
go m = do
|
|
url' PackageR
|
|
url' PackageSnapshotsR
|
|
where
|
|
url' floc = url $ floc $ PackageName $ packageName m
|
|
|
|
|
|
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
|
|
}
|