diff --git a/Handler/Feed.hs b/Handler/Feed.hs index 76b0e6f..3e39457 100644 --- 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 diff --git a/Handler/OldLinks.hs b/Handler/OldLinks.hs index 11f33ea..052a3d1 100644 --- 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 diff --git a/Handler/Sitemap.hs b/Handler/Sitemap.hs index 226f2a1..4d60c7c 100644 --- 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 diff --git a/Handler/Snapshots.hs b/Handler/Snapshots.hs index 0b61b79..b1feeec 100644 --- 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 diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index e81d019..7ee954d 100644 --- 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 diff --git a/Stackage/Database.hs b/Stackage/Database.hs index ce1b92b..1233fb3 100644 --- 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 diff --git a/Types.hs b/Types.hs index f166a5b..d4e97d2 100644 --- 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) diff --git a/config/routes b/config/routes index 8815f4f..9303cd0 100644 --- 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