haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-04-19 03:04:15 +02:00
Code Issues Actions Packages Projects Releases Wiki Activity

Use StackageBranch in OldLinks

Browse Source
This commit is contained in:
Konstantin Zudov 2015-10-16 09:48:33 +03:00
parent e66813be9f
commit 5133a38006
3 changed files with 8 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
Handler/OldLinks.hs
View File

@ -1,7 +1,5 @@
module Handler.OldLinks module Handler.OldLinks
( getOldLtsR ( getOldStackageBranchR
, getOldLtsMajorR
, getOldNightlyR
, getOldSnapshotR , getOldSnapshotR
) where ) where
@ -28,8 +26,8 @@ redirectWithQueryText url = do
req <- waiRequest req <- waiRequest
redirect $ url ++ decodeUtf8 (rawQueryString req) redirect $ url ++ decodeUtf8 (rawQueryString req)
getOldLtsR :: [Text] -> Handler () getOldStackageBranchR :: StackageBranch -> [Text] -> Handler ()
getOldLtsR pieces = do getOldStackageBranchR LtsBranch pieces = do
(x, y, pieces') <- case pieces of (x, y, pieces') <- case pieces of
t:ts | Just suffix <- parseLtsSuffix t -> do t:ts | Just suffix <- parseLtsSuffix t -> do
(x, y) <- case suffix of (x, y) <- case suffix of
@ -44,14 +42,12 @@ getOldLtsR pieces = do
let name = concat ["lts-", tshow x, ".", tshow y] let name = concat ["lts-", tshow x, ".", tshow y]
redirectWithQueryText $ concatMap (cons '/') $ name : pieces' redirectWithQueryText $ concatMap (cons '/') $ name : pieces'
getOldLtsMajorR :: LtsMajor -> [Text] -> Handler () getOldStackageBranchR (LtsMajorBranch x) pieces = do
getOldLtsMajorR (LtsMajor x) pieces = do
y <- newestLTSMajor x >>= maybe notFound return y <- newestLTSMajor x >>= maybe notFound return
let name = concat ["lts-", tshow x, ".", tshow y] let name = concat ["lts-", tshow x, ".", tshow y]
redirectWithQueryText $ concatMap (cons '/') $ name : pieces redirectWithQueryText $ concatMap (cons '/') $ name : pieces
getOldNightlyR :: [Text] -> Handler () getOldStackageBranchR NightlyBranch pieces = do
getOldNightlyR pieces = do
(day, pieces') <- case pieces of (day, pieces') <- case pieces of
t:ts | Just day <- fromPathPiece t -> return (day, ts) t:ts | Just day <- fromPathPiece t -> return (day, ts)
_ -> do _ -> do

4
Handler/Sitemap.hs
View File

@ -11,10 +11,10 @@ getSitemapR :: Handler TypedContent
getSitemapR = sitemap $ do getSitemapR = sitemap $ do
priority 1.0 $ HomeR priority 1.0 $ HomeR
priority 0.9 $ OldLtsR [] priority 0.9 $ OldStackageBranchR LtsBranch []
-- TODO: uncomment when this is presentable -- TODO: uncomment when this is presentable
--priority 0.9 $ DownloadR --priority 0.9 $ DownloadR
priority 0.8 $ OldNightlyR [] priority 0.8 $ OldStackageBranchR NightlyBranch []
priority 0.7 $ AllSnapshotsR priority 0.7 $ AllSnapshotsR
priority 0.7 $ PackageListR priority 0.7 $ PackageListR

5
config/routes
View File

@ -1,4 +1,4 @@
!/#LtsMajor/*Texts OldLtsMajorR GET !/#StackageBranch/*Texts OldStackageBranchR GET
/static StaticR Static getStatic /static StaticR Static getStatic
/reload WebsiteContentR GitRepo-WebsiteContent websiteContent /reload WebsiteContentR GitRepo-WebsiteContent websiteContent
@ -32,9 +32,6 @@
/package/#PackageName/snapshots PackageSnapshotsR GET /package/#PackageName/snapshots PackageSnapshotsR GET
/package PackageListR GET /package PackageListR GET
/lts/*Texts OldLtsR GET
/nightly/*Texts OldNightlyR GET
/authors AuthorsR GET /authors AuthorsR GET
/install InstallR GET /install InstallR GET
/older-releases OlderReleasesR GET /older-releases OlderReleasesR GET