Added UI for snapshot diffs

Handler/StackageHome.hs

@@ -1,13 +1,18 @@
 module Handler.StackageHome
     ( getStackageHomeR
+    , getStackageDiffR
     , getStackageCabalConfigR
     , getDocsR
     , getSnapshotPackagesR
     ) where
 
 import Import
+import qualified Data.HashMap.Strict as HashMap
+import Data.These
 import Data.Time (FormatTime)
 import Stackage.Database
+import Stackage.Database.Types (sortNicely)
+import Stackage.Snapshot.Diff
 
 getStackageHomeR :: SnapName -> Handler Html
 getStackageHomeR name = do
@@ -23,6 +28,17 @@ getStackageHomeR name = do
         $(widgetFile "stackage-home")
   where strip x = fromMaybe x (stripSuffix "." x)
 
+getStackageDiffR :: SnapName -> SnapName -> Handler Html
+getStackageDiffR name1 name2 = do
+    Entity sid1 s1 <- lookupSnapshot name1 >>= maybe notFound return
+    Entity sid2 s2 <- lookupSnapshot name2 >>= maybe notFound return
+    snapNames <- sortNicely . map snapshotName . snd <$> getSnapshots 0 0
+    snapDiff <- getSnapshotDiff sid1 sid2
+    defaultLayout $ do
+        setTitle $ "Compare " ++ toHtml (toPathPiece name1) ++ " with "
+                              ++ toHtml (toPathPiece name2)
+        $(widgetFile "stackage-diff")
+
 getStackageCabalConfigR :: SnapName -> Handler TypedContent
 getStackageCabalConfigR name = do
     Entity sid _ <- lookupSnapshot name >>= maybe notFound return

Stackage/Database/Types.hs

@@ -1,5 +1,6 @@
 module Stackage.Database.Types
     ( SnapName (..)
+    , sortNicely
     ) where
 
 import ClassyPrelude.Conduit
@@ -10,7 +11,21 @@ import Database.Persist.Sql
 
 data SnapName = SNLts !Int !Int
               | SNNightly !Day
-    deriving (Eq, Read, Show)
+    deriving (Eq, Ord, Read, Show)
+
+isLTS :: SnapName -> Bool
+isLTS SNLts{}     = True
+isLTS SNNightly{} = False
+
+-- | Sorts a list of SnapName's in a way suitable for rendering a select list.
+--   Order:
+--     1. LTS snapshots (recent first)
+--     2. Nightly snapshots (recent first)
+--     3. Anything else
+sortNicely :: [SnapName] -> [SnapName]
+sortNicely ns = reverse (sort lts) ++ reverse (sort nightly)
+  where (lts, nightly) = partition isLTS ns
+
 instance PersistField SnapName where
     toPersistValue = toPersistValue . toPathPiece
     fromPersistValue v = do

config/routes

@@ -24,6 +24,8 @@
     /build-plan BuildPlanR GET
     /ghc-major-version GhcMajorVersionR GET
 
+/diff/#SnapName/#SnapName StackageDiffR GET
+
 /system SystemR GET
 /haddock/#SnapName/*Texts HaddockR GET
 /package/#PackageName PackageR GET

templates/stackage-diff.hamlet

@@ -0,0 +1,33 @@
+<h1>Compare Stackage snapshots
+
+<div .container .content>
+  <div .packages>
+    <table .table>
+      <thead>
+        <th>
+          <select .form-control onchange="document.location = this.value">
+            $forall name1' <- snapNames
+              $if name1' == name1
+                <option selected value=@{StackageDiffR name1' name2}>#{toPathPiece name1'}
+              $else
+                <option value=@{StackageDiffR name1' name2}>#{toPathPiece name1'}
+        <th>
+          <select .form-control onchange="document.location = this.value">
+            $forall name2' <- snapNames
+              $if name2' == name2
+                <option selected value=@{StackageDiffR name1 name2'}>#{toPathPiece name2'}
+              $else
+                <option value=@{StackageDiffR name1 name2'}>#{toPathPiece name2'}
+      <tbody>
+        $forall (name, VersionChange verChange) <- HashMap.toList snapDiff
+          <tr>
+            $case verChange
+              $of This oldVersion
+                <td>#{name}-#{oldVersion}
+                <td>
+              $of That newVersion
+                <td>
+                <td>#{name}-#{newVersion}
+              $of These oldVersion newVersion
+                <td>#{name}-#{oldVersion}
+                <td>#{name}-#{newVersion}