Merge pull request #134 from fpco/jsonDiff

Provide JSON representation of the snapshot diff

Handler/Feed.hs

@@ -5,9 +5,8 @@ module Handler.Feed
 
 import Import
 import Stackage.Database
-import           Data.These
+import Data.These
 import Stackage.Snapshot.Diff
-import qualified Data.HashMap.Strict as HashMap
 import Text.Blaze (text)
 
 getFeedR :: Handler TypedContent
@@ -52,10 +51,7 @@ mkFeed mBranch snaps = do
 
 getContent :: SnapshotId -> Snapshot -> Handler Html
 getContent sid2 snap = do
-    mprev <-
+    mprev <- snapshotBefore $ snapshotName snap
-        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
@@ -70,17 +66,17 @@ getContent sid2 snap = do
                         <th align=right>Old
                         <th align=left>New
                     <tbody>
-                      $forall (name, VersionChange verChange) <- sortOn (toCaseFold . fst) $ HashMap.toList snapDiff
+                      $forall (PackageName name, VersionChange change) <- toDiffList snapDiff
                         <tr>
                           <th align=right>#{name}
-                          $case verChange
+                          $case change
-                            $of This oldVersion
+                            $of This (Version old)
-                              <td align=right>#{oldVersion}
+                              <td align=right>#{old}
                               <td>
-                            $of That newVersion
+                            $of That (Version new)
                               <td align=right>
-                              <td>#{newVersion}
+                              <td>#{new}
-                            $of These oldVersion newVersion
+                            $of These (Version old) (Version new)
-                              <td align=right>#{oldVersion}
+                              <td align=right>#{old}
-                              <td>#{newVersion}
+                              <td>#{new}
                 |]

Handler/StackageHome.hs

@@ -7,7 +7,6 @@ module Handler.StackageHome
     ) where
 
 import Import
-import qualified Data.HashMap.Strict as HashMap
 import Data.These
 import Data.Time (FormatTime)
 import Stackage.Database
@@ -28,17 +27,19 @@ getStackageHomeR name = do
         $(widgetFile "stackage-home")
   where strip x = fromMaybe x (stripSuffix "." x)
 
-getStackageDiffR :: SnapName -> SnapName -> Handler Html
+getStackageDiffR :: SnapName -> SnapName -> Handler TypedContent
 getStackageDiffR name1 name2 = do
     Entity sid1 _ <- lookupSnapshot name1 >>= maybe notFound return
     Entity sid2 _ <- lookupSnapshot name2 >>= maybe notFound return
     (map (snapshotName . entityVal) -> snapNames) <- getSnapshots Nothing 0 0
     let (ltsSnaps, nightlySnaps) = partition isLts $ reverse $ sort snapNames
     snapDiff <- getSnapshotDiff sid1 sid2
-    defaultLayout $ do
+    selectRep $ do
-        setTitle $ "Compare " ++ toHtml (toPathPiece name1) ++ " with "
+        provideRep $ defaultLayout $ do
-                              ++ toHtml (toPathPiece name2)
+            setTitle $ "Compare " ++ toHtml (toPathPiece name1) ++ " with "
-        $(widgetFile "stackage-diff")
+                                  ++ toHtml (toPathPiece name2)
+            $(widgetFile "stackage-diff")
+        provideRep $ pure $ toJSON $ WithSnapshotNames name1 name2 snapDiff
 
 getStackageCabalConfigR :: SnapName -> Handler TypedContent
 getStackageCabalConfigR name = do

Stackage/Database.hs

@@ -10,8 +10,6 @@ module Stackage.Database
     , newestNightly
     , ltsMajorVersions
     , snapshotBefore
-    , nightlyBefore
-    , ltsBefore
     , lookupSnapshot
     , snapshotTitle
     , PackageListingInfo (..)

Stackage/Database/Types.hs

@@ -6,6 +6,7 @@ module Stackage.Database.Types
 
 import ClassyPrelude.Conduit
 import Web.PathPieces
+import Data.Aeson.Extra
 import Data.Text.Read (decimal)
 import Database.Persist
 import Database.Persist.Sql
@@ -22,6 +23,9 @@ isNightly :: SnapName -> Bool
 isNightly SNLts{}     = False
 isNightly SNNightly{} = True
 
+instance ToJSONKey SnapName where
+    toJSONKey = toPathPiece
+
 instance PersistField SnapName where
     toPersistValue = toPersistValue . toPathPiece
     fromPersistValue v = do
@@ -45,3 +49,4 @@ instance PathPiece SnapName where
             t3 <- stripPrefix "." t2
             Right (y, "") <- Just $ decimal t3
             return $ SNLts x y
+

Stackage/Snapshot/Diff.hs

@@ -2,21 +2,39 @@
 module Stackage.Snapshot.Diff
   ( getSnapshotDiff
   , snapshotDiff
-  , SnapshotDiff
+  , SnapshotDiff()
+  , toDiffList
   , VersionChange(..)
+  , WithSnapshotNames(..)
   ) where
 
-import qualified Data.HashMap.Strict as HashMap
 import           Data.Align
+import           Data.Aeson.Extra
+import qualified Data.HashMap.Strict as HashMap
 import           Control.Arrow
 import           ClassyPrelude
 import           Data.These
 import           Stackage.Database (SnapshotId, PackageListingInfo(..),
                                     GetStackageDatabase, getPackages)
-type PackageName = Text
+import           Stackage.Database.Types (SnapName)
-type Version = Text
+import           Types
+import           Web.PathPieces
 
-type SnapshotDiff = HashMap PackageName VersionChange
+data WithSnapshotNames a
+    = WithSnapshotNames SnapName SnapName a
+
+newtype SnapshotDiff
+    = SnapshotDiff { unSnapshotDiff :: HashMap PackageName VersionChange }
+    deriving (Show, Eq, Generic, Typeable)
+
+instance ToJSON (WithSnapshotNames SnapshotDiff) where
+    toJSON (WithSnapshotNames nameA nameB (SnapshotDiff diff)) =
+        object [ "comparing" .= [toPathPiece nameA, toPathPiece nameB]
+               , "diff"      .= Object (toJSONMap (WithSnapshotNames nameA nameB <$> diff))
+               ]
+
+toDiffList :: SnapshotDiff -> [(PackageName, VersionChange)]
+toDiffList = sortOn (toCaseFold . unPackageName . fst) . HashMap.toList . unSnapshotDiff
 
 -- | Versions of a package as it occurs in the listings provided to `snapshotDiff`.
 --
@@ -24,6 +42,14 @@ type SnapshotDiff = HashMap PackageName VersionChange
 --   otherwise it would be `This v1` if the package is present only in the first listing,
 --   or `That v2` if only in the second.
 newtype VersionChange = VersionChange { unVersionChange :: These Version Version }
+                      deriving (Show, Eq, Generic, Typeable)
+
+instance ToJSON (WithSnapshotNames VersionChange) where
+    toJSON (WithSnapshotNames (toJSONKey -> aKey) (toJSONKey -> bKey) change) =
+        case change of
+            VersionChange (This a)    -> object [ aKey .= a ]
+            VersionChange (That b)    -> object [ bKey .= b ]
+            VersionChange (These a b) -> object [ aKey .= a, bKey .= b ]
 
 changed :: VersionChange -> Bool
 changed = these (const True) (const True) (/=) . unVersionChange
@@ -32,6 +58,8 @@ getSnapshotDiff :: GetStackageDatabase m => SnapshotId -> SnapshotId -> m Snapsh
 getSnapshotDiff a b = snapshotDiff <$> getPackages a <*> getPackages b
 
 snapshotDiff :: [PackageListingInfo] -> [PackageListingInfo] -> SnapshotDiff
-snapshotDiff as bs = HashMap.filter changed $ alignWith VersionChange (toMap as) (toMap bs)
+snapshotDiff as bs =
+    SnapshotDiff $ HashMap.filter changed
+                 $ alignWith VersionChange (toMap as) (toMap bs)
   where
-    toMap = HashMap.fromList . map (pliName &&& pliVersion)
+    toMap = HashMap.fromList . map (PackageName . pliName &&& Version . pliVersion)

Types.hs

@@ -1,7 +1,7 @@
 module Types where
 
 import ClassyPrelude.Yesod
-import Data.Aeson
+import Data.Aeson.Extra
 import Data.Hashable (hashUsing)
 import Text.Blaze (ToMarkup)
 import Database.Persist.Sql (PersistFieldSql (sqlType))
@@ -29,10 +29,16 @@ instance PathPiece SnapshotBranch where
 
 newtype PackageName = PackageName { unPackageName :: Text }
     deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, IsString)
+instance ToJSON PackageName where
+    toJSON = toJSON . unPackageName
+instance ToJSONKey PackageName where
+    toJSONKey = unPackageName
 instance PersistFieldSql PackageName where
     sqlType = sqlType . liftM unPackageName
 newtype Version = Version { unVersion :: Text }
     deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField)
+instance ToJSON Version where
+    toJSON = toJSON . unVersion
 instance PersistFieldSql Version where
     sqlType = sqlType . liftM unVersion
 newtype PackageSetIdent = PackageSetIdent { unPackageSetIdent :: Text }

stackage-server.cabal

@@ -91,6 +91,7 @@ library
     build-depends:
                     base                          >= 4.8         &&   < 4.9
                   , aeson                         >= 0.8         &&   < 0.9
+                  , aeson-extra                   >= 0.2         &&   < 0.3
                   , aws                           >= 0.12        &&   < 0.13
                   , barrier                       >= 0.1         &&   < 0.2
                   , base16-bytestring             >= 0.1         &&   < 0.2

templates/stackage-diff.hamlet

@@ -33,15 +33,15 @@
                 $else
                   <option value=@{StackageDiffR name1 name2'}>#{toPathPiece name2'}
       <tbody>
-        $forall (name, VersionChange verChange) <- sortOn (toCaseFold . fst) $ HashMap.toList snapDiff
+        $forall (PackageName name, VersionChange verChange) <- toDiffList snapDiff
           <tr>
             $case verChange
-              $of This oldVersion
+              $of This (Version oldVersion)
                 <td>#{name}-#{oldVersion}
                 <td>
-              $of That newVersion
+              $of That (Version newVersion)
                 <td>
                 <td>#{name}-#{newVersion}
-              $of These oldVersion newVersion
+              $of These (Version oldVersion) (Version newVersion)
                 <td>#{name}-#{oldVersion}
                 <td>#{name}-#{newVersion}