StackageBranch -> SnapshotBranch

This commit is contained in:
Konstantin Zudov 2015-10-16 15:01:40 +03:00
parent e4a9880fde
commit c2fb5b1fa5
6 changed files with 19 additions and 19 deletions

View file

@ -13,13 +13,13 @@ import Text.Blaze (text)
getFeedR :: Handler TypedContent
getFeedR = getBranchFeed Nothing
getBranchFeedR :: StackageBranch -> Handler TypedContent
getBranchFeedR :: SnapshotBranch -> Handler TypedContent
getBranchFeedR = getBranchFeed . Just
getBranchFeed :: Maybe StackageBranch -> Handler TypedContent
getBranchFeed :: Maybe SnapshotBranch -> Handler TypedContent
getBranchFeed mBranch = mkFeed mBranch =<< getSnapshots mBranch 20 0
mkFeed :: Maybe StackageBranch -> [Entity Snapshot] -> Handler TypedContent
mkFeed :: Maybe SnapshotBranch -> [Entity Snapshot] -> Handler TypedContent
mkFeed _ [] = notFound
mkFeed mBranch snaps = do
entries <- forM snaps $ \(Entity snapid snap) -> do

View file

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

View file

@ -11,8 +11,8 @@ getSitemapR :: Handler TypedContent
getSitemapR = sitemap $ do
priority 1.0 $ HomeR
priority 0.9 $ OldStackageBranchR LtsBranch []
priority 0.8 $ OldStackageBranchR NightlyBranch []
priority 0.9 $ OldSnapshotBranchR LtsBranch []
priority 0.8 $ OldSnapshotBranchR NightlyBranch []
priority 0.7 $ AllSnapshotsR
priority 0.7 $ PackageListR

View file

@ -69,7 +69,7 @@ import System.IO.Temp
import qualified Database.Esqueleto as E
import Data.Yaml (decode)
import qualified Data.Aeson as A
import Types (StackageBranch(..))
import Types (SnapshotBranch(..))
currentSchema :: Int
currentSchema = 1
@ -663,16 +663,16 @@ getSnapshotsForPackage pname = run $ do
Nothing -> Nothing
Just s -> Just (s, snapshotPackageVersion sp)
-- | Count snapshots that belong to a specific StackageBranch
countSnapshots :: (GetStackageDatabase m) => Maybe StackageBranch -> m Int
-- | Count snapshots that belong to a specific SnapshotBranch
countSnapshots :: (GetStackageDatabase m) => Maybe SnapshotBranch -> m Int
countSnapshots Nothing = run $ count ([] :: [Filter Snapshot])
countSnapshots (Just NightlyBranch) = run $ count ([] :: [Filter Nightly])
countSnapshots (Just LtsBranch) = run $ count ([] :: [Filter Lts])
countSnapshots (Just (LtsMajorBranch x)) = run $ count [LtsMajor ==. x]
-- | Get snapshots that belong to a specific StackageBranch
-- | Get snapshots that belong to a specific SnapshotBranch
getSnapshots :: (GetStackageDatabase m)
=> Maybe StackageBranch
=> Maybe SnapshotBranch
-> Int -- ^ limit
-> Int -- ^ offset
-> m [Entity Snapshot]

View file

@ -11,11 +11,11 @@ import qualified Data.Text.Lazy.Builder as Builder
import qualified Data.Text.Lazy as LText
import qualified Data.Text.Read as Reader
data StackageBranch = LtsMajorBranch Int
data SnapshotBranch = LtsMajorBranch Int
| LtsBranch
| NightlyBranch
deriving (Eq, Read, Show)
instance PathPiece StackageBranch where
instance PathPiece SnapshotBranch where
toPathPiece NightlyBranch = "nightly"
toPathPiece LtsBranch = "lts"
toPathPiece (LtsMajorBranch x) = "lts-" ++ tshow x

View file

@ -1,4 +1,4 @@
!/#StackageBranch/*Texts OldStackageBranchR GET
!/#SnapshotBranch/*Texts OldSnapshotBranchR GET
/static StaticR Static getStatic
/reload WebsiteContentR GitRepo-WebsiteContent websiteContent
@ -44,7 +44,7 @@
/download/#SupportedArch/#Text DownloadGhcLinksR GET
/feed FeedR GET
/feed/#StackageBranch BranchFeedR GET
/feed/#SnapshotBranch BranchFeedR GET
/stack DownloadStackListR GET
/stack/#Text DownloadStackR GET