Merge pull request #133 from fpco/stackageBranch

SnapshotBranch
8 years ago · c3a59798cb
parent 90cc9ea5c1 c2fb5b1fa5
commit c3a59798cb
8 changed files with 71 additions and 96 deletions
--- a/Handler/Feed.hs
+++ b/Handler/Feed.hs
@ -1,8 +1,6 @@
 module Handler.Feed
    ( getFeedR
-    , getLtsFeedR
-    , getLtsMajorFeedR
-    , getNightlyFeedR
+    , getBranchFeedR
    ) where

 import Import
@ -13,21 +11,17 @@ import qualified Data.HashMap.Strict as HashMap
 import Text.Blaze (text)

 getFeedR :: Handler TypedContent
-getFeedR = mkFeed "" . snd =<< getSnapshots 20 0
+getFeedR = getBranchFeed Nothing

-getLtsFeedR :: Handler TypedContent
-getLtsFeedR = mkFeed "LTS" . snd =<< getLtsSnapshots 20 0
+getBranchFeedR :: SnapshotBranch -> Handler TypedContent
+getBranchFeedR = getBranchFeed . Just

-getLtsMajorFeedR :: LtsMajor -> Handler TypedContent
-getLtsMajorFeedR (LtsMajor v) =
-    mkFeed ("LTS-" <> tshow v) . snd =<< getLtsMajorSnapshots v 20 0
+getBranchFeed :: Maybe SnapshotBranch -> Handler TypedContent
+getBranchFeed mBranch = mkFeed mBranch =<< getSnapshots mBranch 20 0

-getNightlyFeedR :: Handler TypedContent
-getNightlyFeedR = mkFeed "Nightly" . snd =<< getNightlySnapshots 20 0
-
-mkFeed :: Text -> [Entity Snapshot] -> Handler TypedContent
+mkFeed :: Maybe SnapshotBranch -> [Entity Snapshot] -> Handler TypedContent
 mkFeed _ [] = notFound
-mkFeed branch snaps = do
+mkFeed mBranch snaps = do
    entries <- forM snaps $ \(Entity snapid snap) -> do
        content <- getContent snapid snap
        return FeedEntry
@ -41,15 +35,20 @@ mkFeed branch snaps = do
            [] -> liftIO getCurrentTime
            x:_ -> return $ feedEntryUpdated x
    newsFeed Feed
-        { feedTitle = "Recent Stackage " <> branch <> " snapshots"
+        { feedTitle = title
        , feedLinkSelf = FeedR
        , feedLinkHome = HomeR
        , feedAuthor = "Stackage Project"
-        , feedDescription = text ("Recent Stackage " <> branch <> " snapshots")
+        , feedDescription = text title
        , feedLanguage = "en"
        , feedUpdated = updated
        , feedEntries = entries
        }
+  where
+    branchTitle NightlyBranch = "Nightly"
+    branchTitle LtsBranch     = "LTS"
+    branchTitle (LtsMajorBranch x) = "LTS-" <> tshow x
+    title = "Recent Stackage " <> maybe "" branchTitle mBranch <> " snapshots"

 getContent :: SnapshotId -> Snapshot -> Handler Html
 getContent sid2 snap = do
--- a/Handler/OldLinks.hs
+++ b/Handler/OldLinks.hs
@ -1,7 +1,5 @@
 module Handler.OldLinks
-    ( getOldLtsR
-    , getOldLtsMajorR
-    , getOldNightlyR
+    ( getOldSnapshotBranchR
    , getOldSnapshotR
    ) where

@ -28,8 +26,8 @@ redirectWithQueryText url = do
    req <- waiRequest
    redirect $ url ++ decodeUtf8 (rawQueryString req)

-getOldLtsR :: [Text] -> Handler ()
-getOldLtsR 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
@ -44,14 +42,12 @@ getOldLtsR pieces = do
    let name = concat ["lts-", tshow x, ".", tshow y]
    redirectWithQueryText $ concatMap (cons '/') $ name : pieces'

-getOldLtsMajorR :: LtsMajor -> [Text] -> Handler ()
-getOldLtsMajorR (LtsMajor 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

-getOldNightlyR :: [Text] -> Handler ()
-getOldNightlyR pieces = do
+getOldSnapshotBranchR NightlyBranch pieces = do
    (day, pieces') <- case pieces of
        t:ts | Just day <- fromPathPiece t -> return (day, ts)
        _ -> do
--- a/Handler/Sitemap.hs
+++ b/Handler/Sitemap.hs
@ -11,10 +11,8 @@ 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.9 $ OldSnapshotBranchR LtsBranch []
+    priority 0.8 $ OldSnapshotBranchR NightlyBranch []

    priority 0.7 $ AllSnapshotsR
    priority 0.7 $ PackageListR
--- a/Handler/Snapshots.hs
+++ b/Handler/Snapshots.hs
@ -24,9 +24,10 @@ getAllSnapshotsR = do
    currentPageMay <- lookupGetParam "page"
    let currentPage :: Int
        currentPage = fromMaybe 1 (currentPageMay >>= readMay)
-    (totalCount, map entityVal -> snapshots) <- getSnapshots
-        snapshotsPerPage
-        ((fromIntegral currentPage - 1) * snapshotsPerPage)
+    totalCount <- countSnapshots Nothing
+    (map entityVal -> snapshots) <-
+        getSnapshots Nothing snapshotsPerPage
+                             ((fromIntegral currentPage - 1) * snapshotsPerPage)
    let groups = groupUp now' snapshots

    let isFirstPage = currentPage == 1
--- a/Handler/StackageHome.hs
+++ b/Handler/StackageHome.hs
@ -32,7 +32,7 @@ getStackageDiffR :: SnapName -> SnapName -> Handler Html
 getStackageDiffR name1 name2 = do
    Entity sid1 _ <- lookupSnapshot name1 >>= maybe notFound return
    Entity sid2 _ <- lookupSnapshot name2 >>= maybe notFound return
-    snapNames <- map (snapshotName . entityVal) . snd <$> getSnapshots 0 0
+    (map (snapshotName . entityVal) -> snapNames) <- getSnapshots Nothing 0 0
    let (ltsSnaps, nightlySnaps) = partition isLts $ reverse $ sort snapNames
    snapDiff <- getSnapshotDiff sid1 sid2
    defaultLayout $ do
--- a/Stackage/Database.hs
+++ b/Stackage/Database.hs
@ -34,9 +34,7 @@ module Stackage.Database
    , prettyNameShort
    , getSnapshotsForPackage
    , getSnapshots
-    , getLtsSnapshots
-    , getLtsMajorSnapshots
-    , getNightlySnapshots
+    , countSnapshots
    , currentSchema
    , last5Lts5Nightly
    , snapshotsJSON
@ -71,6 +69,7 @@ import System.IO.Temp
 import qualified Database.Esqueleto as E
 import Data.Yaml (decode)
 import qualified Data.Aeson as A
+import Types (SnapshotBranch(..))

 currentSchema :: Int
 currentSchema = 1
@ -664,64 +663,44 @@ getSnapshotsForPackage pname = run $ do
            Nothing -> Nothing
            Just s -> Just (s, snapshotPackageVersion sp)

-getSnapshots
-    :: GetStackageDatabase m
-    => Int -- ^ limit
-    -> Int -- ^ offset
-    -> m (Int, [Entity Snapshot])
-getSnapshots l o = run $ (,)
-    <$> count ([] :: [Filter Snapshot])
-    <*> selectList
-        []
-        [LimitTo l, OffsetBy o, Desc SnapshotCreated]
-
-getLtsSnapshots :: GetStackageDatabase m
-                => Int -- ^ limit
-                -> Int -- ^ offset
-                -> m (Int, [Entity Snapshot])
-getLtsSnapshots l o = run $ do
-    ltsCount <- count ([] :: [Filter Lts])
-    snapshots <- E.select $ E.from $
-        \(lts `E.InnerJoin` snapshot) -> do
+-- | 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 SnapshotBranch
+getSnapshots :: (GetStackageDatabase m)
+             => Maybe SnapshotBranch
+             -> Int -- ^ limit
+             -> Int -- ^ offset
+             -> m [Entity Snapshot]
+getSnapshots mBranch l o = run $ case mBranch of
+    Nothing -> selectList [] [LimitTo l, OffsetBy o, Desc SnapshotCreated]
+    Just NightlyBranch ->
+        E.select $ E.from $ \(nightly `E.InnerJoin` snapshot) -> do
+            E.on $ nightly E.^. NightlySnap E.==. snapshot E.^. SnapshotId
+            E.orderBy [E.desc (nightly E.^. NightlyDay)]
+            E.limit $ fromIntegral l
+            E.offset $ fromIntegral o
+            pure snapshot
+    Just LtsBranch -> do
+        E.select $ E.from $ \(lts `E.InnerJoin` snapshot) -> do
            E.on $ lts E.^. LtsSnap E.==. snapshot E.^. SnapshotId
            E.orderBy [ E.desc (lts E.^. LtsMajor)
                      , E.desc (lts E.^. LtsMinor) ]
            E.limit $ fromIntegral l
            E.offset $ fromIntegral o
-            return snapshot
-    return (ltsCount, snapshots)
-
-getLtsMajorSnapshots :: GetStackageDatabase m
-                => Int -- ^ Major version
-                -> Int -- ^ limit
-                -> Int -- ^ offset
-                -> m (Int, [Entity Snapshot])
-getLtsMajorSnapshots v l o = run $ do
-    ltsCount <- count ([] :: [Filter Lts])
-    snapshots <- E.select $ E.from $
-        \(lts `E.InnerJoin` snapshot) -> do
+            pure snapshot
+    Just (LtsMajorBranch v) -> do
+        E.select $ E.from $ \(lts `E.InnerJoin` snapshot) -> do
            E.on $ lts E.^. LtsSnap E.==. snapshot E.^. SnapshotId
            E.orderBy [E.desc (lts E.^. LtsMinor)]
            E.where_ ((lts E.^. LtsMajor) E.==. (E.val v))
            E.limit $ fromIntegral l
            E.offset $ fromIntegral o
-            return snapshot
-    return (ltsCount, snapshots)
-
-getNightlySnapshots :: GetStackageDatabase m
-                => Int -- ^ limit
-                -> Int -- ^ offset
-                -> m (Int, [Entity Snapshot])
-getNightlySnapshots l o = run $ do
-    nightlyCount <- count ([] :: [Filter Nightly])
-    snapshots <- E.select $ E.from $
-        \(nightly `E.InnerJoin` snapshot) -> do
-            E.on $ nightly E.^. NightlySnap E.==. snapshot E.^. SnapshotId
-            E.orderBy [E.desc (nightly E.^. NightlyDay)]
-            E.limit $ fromIntegral l
-            E.offset $ fromIntegral o
-            return snapshot
-    return (nightlyCount, snapshots)
+            pure snapshot

 last5Lts5Nightly :: GetStackageDatabase m => m [SnapName]
 last5Lts5Nightly = run $ do
--- a/Types.hs
+++ b/Types.hs
@ -11,14 +11,21 @@ import qualified Data.Text.Lazy.Builder as Builder
 import qualified Data.Text.Lazy as LText
 import qualified Data.Text.Read as Reader

-newtype LtsMajor = LtsMajor Int
-    deriving (Eq, Read, Show)
-instance PathPiece LtsMajor where
-    toPathPiece (LtsMajor x) = "lts-" ++ tshow x
+data SnapshotBranch = LtsMajorBranch Int
+                    | LtsBranch
+                    | NightlyBranch
+                    deriving (Eq, Read, Show)
+instance PathPiece SnapshotBranch where
+    toPathPiece NightlyBranch = "nightly"
+    toPathPiece LtsBranch     = "lts"
+    toPathPiece (LtsMajorBranch x) = "lts-" ++ tshow x
+
+    fromPathPiece "nightly" = Just NightlyBranch
+    fromPathPiece "lts" = Just LtsBranch
    fromPathPiece t0 = do
        t1 <- stripPrefix "lts-" t0
        Right (x, "") <- Just $ Reader.decimal t1
-        Just $ LtsMajor x
+        Just $ LtsMajorBranch x

 newtype PackageName = PackageName { unPackageName :: Text }
    deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, IsString)
--- a/config/routes
+++ b/config/routes
@ -1,4 +1,4 @@
-!/#LtsMajor/*Texts OldLtsMajorR GET
+!/#SnapshotBranch/*Texts OldSnapshotBranchR GET

 /static StaticR Static getStatic
 /reload WebsiteContentR GitRepo-WebsiteContent websiteContent
@ -32,9 +32,6 @@
 /package/#PackageName/snapshots PackageSnapshotsR GET
 /package PackageListR GET

-/lts/*Texts OldLtsR GET
-/nightly/*Texts OldNightlyR GET
-
 /authors AuthorsR GET
 /install InstallR GET
 /older-releases OlderReleasesR GET
@ -47,9 +44,7 @@
 /download/#SupportedArch/#Text DownloadGhcLinksR GET

 /feed FeedR GET
-!/feed/#LtsMajor LtsMajorFeedR GET
-/feed/lts LtsFeedR GET
-/feed/nightly NightlyFeedR GET
+/feed/#SnapshotBranch BranchFeedR GET

 /stack DownloadStackListR GET
 /stack/#Text DownloadStackR GET