Merge pull request #133 from fpco/stackageBranch

SnapshotBranch

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

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

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

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

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

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]
+-- | 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]
 
-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
+-- | 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

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)

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