ToJSON for SnapshotDiff

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

@@ -5,19 +5,33 @@ module Stackage.Snapshot.Diff
   , 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)
+import           Stackage.Database.Types (SnapName)
 import           Types
+import           Web.PathPieces
+
+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
@@ -28,6 +42,14 @@ toDiffList = sortOn (toCaseFold . unPackageName . fst) . HashMap.toList . unSnap
 --   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

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