From fcc36a3a8123d00b4b393189c75bbe14d6b73fda Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 12 Oct 2015 14:03:43 +0000 Subject: [PATCH] Show snapshot diff on feed --- Handler/Feed.hs | 44 +++++++++++++++++++++++++++++++++++++++-- Handler/Snapshots.hs | 2 +- Handler/StackageHome.hs | 4 ++-- Stackage/Database.hs | 39 ++++++++++++++++++++++++++---------- 4 files changed, 74 insertions(+), 15 deletions(-) diff --git a/Handler/Feed.hs b/Handler/Feed.hs index cb2ab96..fbee2f7 100644 --- a/Handler/Feed.hs +++ b/Handler/Feed.hs @@ -2,15 +2,20 @@ module Handler.Feed where import Import import Stackage.Database +import Data.These +import Stackage.Snapshot.Diff +import qualified Data.HashMap.Strict as HashMap getFeedR :: Handler TypedContent getFeedR = do (_, snaps) <- getSnapshots 20 0 - let entries = flip map snaps $ \snap -> FeedEntry + entries <- forM snaps $ \(Entity snapid snap) -> do + content <- getContent snapid snap + return FeedEntry { feedEntryLink = SnapshotR (snapshotName snap) StackageHomeR , feedEntryUpdated = UTCTime (snapshotCreated snap) 0 , feedEntryTitle = prettyName (snapshotName snap) (snapshotGhc snap) - , feedEntryContent = "" + , feedEntryContent = content } updated <- case entries of @@ -26,3 +31,38 @@ getFeedR = do , feedUpdated = updated , feedEntries = entries } + +getContent :: SnapshotId -> Snapshot -> Handler Html +getContent sid2 snap = do + mprev <- + case snapshotName snap of + SNLts x y -> ltsBefore x y + SNNightly day -> nightlyBefore day + case mprev of + Nothing -> return "No previous snapshot found for comparison" + Just (sid1, name1) -> do + snapDiff <- getSnapshotDiff sid1 sid2 + return + [shamlet| +

Difference between #{prettyNameShort name1} and #{prettyNameShort $ snapshotName snap} + + + + + $forall (name, VersionChange verChange) <- sortOn (toCaseFold . fst) $ HashMap.toList snapDiff + +
Package name + Old + New +
#{name} + $case verChange + $of This oldVersion + #{oldVersion} + + $of That newVersion + + #{newVersion} + $of These oldVersion newVersion + #{oldVersion} + #{newVersion} + |] diff --git a/Handler/Snapshots.hs b/Handler/Snapshots.hs index f48ae0c..0b61b79 100644 --- a/Handler/Snapshots.hs +++ b/Handler/Snapshots.hs @@ -24,7 +24,7 @@ getAllSnapshotsR = do currentPageMay <- lookupGetParam "page" let currentPage :: Int currentPage = fromMaybe 1 (currentPageMay >>= readMay) - (totalCount, snapshots) <- getSnapshots + (totalCount, map entityVal -> snapshots) <- getSnapshots snapshotsPerPage ((fromIntegral currentPage - 1) * snapshotsPerPage) let groups = groupUp now' snapshots diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index 120e5c3..826cfdd 100644 --- a/Handler/StackageHome.hs +++ b/Handler/StackageHome.hs @@ -17,7 +17,7 @@ import Stackage.Snapshot.Diff getStackageHomeR :: SnapName -> Handler Html getStackageHomeR name = do Entity sid snapshot <- lookupSnapshot name >>= maybe notFound return - snapNames <- map snapshotName . snd <$> getSnapshots 0 0 + snapNames <- map (snapshotName . entityVal) . snd <$> getSnapshots 0 0 let hoogleForm = let queryText = "" :: Text exact = False @@ -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 . snd <$> getSnapshots 0 0 + snapNames <- map (snapshotName . entityVal) . snd <$> getSnapshots 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 2f25d76..c5defff 100644 --- a/Stackage/Database.hs +++ b/Stackage/Database.hs @@ -8,6 +8,8 @@ module Stackage.Database , newestLTSMajor , ltsMajorVersions , newestNightly + , nightlyBefore + , ltsBefore , lookupSnapshot , snapshotTitle , PackageListingInfo (..) @@ -28,6 +30,7 @@ module Stackage.Database , Package (..) , getPackage , prettyName + , prettyNameShort , getSnapshotsForPackage , getSnapshots , currentSchema @@ -422,6 +425,22 @@ newestNightly :: GetStackageDatabase m => m (Maybe Day) newestNightly = run $ liftM (fmap $ nightlyDay . entityVal) $ selectFirst [] [Desc NightlyDay] +nightlyBefore :: GetStackageDatabase m => Day -> m (Maybe (SnapshotId, SnapName)) +nightlyBefore day = do + run $ liftM (fmap go) $ selectFirst [NightlyDay <. day] [Desc NightlyDay] + where + go (Entity _ nightly) = (nightlySnap nightly, SNNightly $ nightlyDay nightly) + +ltsBefore :: GetStackageDatabase m => Int -> Int -> m (Maybe (SnapshotId, SnapName)) +ltsBefore x y = do + run $ liftM (fmap go) $ selectFirst + ( [LtsMajor <=. x, LtsMinor <. y] ||. + [LtsMajor <. x] + ) + [Desc LtsMajor, Desc LtsMinor] + where + go (Entity _ lts) = (ltsSnap lts, SNLts (ltsMajor lts) (ltsMinor lts)) + lookupSnapshot :: GetStackageDatabase m => SnapName -> m (Maybe (Entity Snapshot)) lookupSnapshot name = run $ getBy $ UniqueSnapshot name @@ -429,13 +448,13 @@ snapshotTitle :: Snapshot -> Text snapshotTitle s = prettyName (snapshotName s) (snapshotGhc s) prettyName :: SnapName -> Text -> Text -prettyName name ghc = - concat [base, " - GHC ", ghc] - where - base = - case name of - SNLts x y -> concat ["LTS Haskell ", tshow x, ".", tshow y] - SNNightly d -> "Stackage Nightly " ++ tshow d +prettyName name ghc = concat [prettyNameShort name, " - GHC ", ghc] + +prettyNameShort :: SnapName -> Text +prettyNameShort name = + case name of + SNLts x y -> concat ["LTS Haskell ", tshow x, ".", tshow y] + SNNightly d -> "Stackage Nightly " ++ tshow d getAllPackages :: GetStackageDatabase m => m [(Text, Text, Text)] -- FIXME add information on whether included in LTS and Nightly getAllPackages = liftM (map toPair) $ run $ do @@ -640,12 +659,12 @@ getSnapshots :: GetStackageDatabase m => Int -- ^ limit -> Int -- ^ offset - -> m (Int, [Snapshot]) + -> m (Int, [Entity Snapshot]) getSnapshots l o = run $ (,) <$> count ([] :: [Filter Snapshot]) - <*> fmap (map entityVal) (selectList + <*> selectList [] - [LimitTo l, OffsetBy o, Desc SnapshotCreated]) + [LimitTo l, OffsetBy o, Desc SnapshotCreated] last5Lts5Nightly :: GetStackageDatabase m => m [SnapName] last5Lts5Nightly = run $ do