Show snapshot diff on feed

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|
+                  <p>Difference between #{prettyNameShort name1} and #{prettyNameShort $ snapshotName snap}
+                  <table border=1 cellpadding=5>
+                    <thead>
+                      <tr>
+                        <th align=right>Package name
+                        <th align=right>Old
+                        <th align=left>New
+                    <tbody>
+                      $forall (name, VersionChange verChange) <- sortOn (toCaseFold . fst) $ HashMap.toList snapDiff
+                        <tr>
+                          <th align=right>#{name}
+                          $case verChange
+                            $of This oldVersion
+                              <td align=right>#{oldVersion}
+                              <td>
+                            $of That newVersion
+                              <td align=right>
+                              <td>#{newVersion}
+                            $of These oldVersion newVersion
+                              <td align=right>#{oldVersion}
+                              <td>#{newVersion}
+                |]

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

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

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