From 912a0175d445128f52e530d9f5179febf7119c72 Mon Sep 17 00:00:00 2001
From: Konstantin Zudov <co@zudov.me>
Date: Tue, 2 Feb 2016 03:08:49 +0200
Subject: [PATCH] Provide snapshot content as JSON

```json
$ http --json http://localhost:4000/lts-5.1
{
  "snapshot": {
    "ghc": "7.10.3",
    "created": "2016-01-30",
    "name": "lts-5.1"
  },
  "packages": [
    {
      "isCore": false,
      "name": "abstract-deque",
      "version": "0.3",
      "synopsis": "Abstract, parameterized interface to mutable Deques."
    },
    {
      "isCore": false,
      "name": "abstract-par",
      "version": "0.3.3",
      "synopsis": "Type classes generalizing the functionality of the 'monad-par' library."
    },
    ...
  ]
}

```
---
 Handler/StackageHome.hs    | 24 +++++++++++++++++++-----
 Stackage/Database.hs       | 15 +++++++++++++++
 Stackage/Database/Types.hs |  3 +++
 3 files changed, 37 insertions(+), 5 deletions(-)

diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs
index c8626e6..9e1fc79 100644
--- a/Handler/StackageHome.hs
+++ b/Handler/StackageHome.hs
@@ -13,7 +13,7 @@ import Stackage.Database
 import Stackage.Database.Types (isLts)
 import Stackage.Snapshot.Diff
 
-getStackageHomeR :: SnapName -> Handler Html
+getStackageHomeR :: SnapName -> Handler TypedContent
 getStackageHomeR name = do
     Entity sid snapshot <- lookupSnapshot name >>= maybe notFound return
     previousSnapName <- fromMaybe name . map snd <$> snapshotBefore (snapshotName snapshot)
@@ -22,12 +22,26 @@ getStackageHomeR name = do
                 exact = False
             in $(widgetFile "hoogle-form")
     packageCount <- getPackageCount sid
-    defaultLayout $ do
-        setTitle $ toHtml $ snapshotTitle snapshot
-        packages <- getPackages sid
-        $(widgetFile "stackage-home")
+    packages <- getPackages sid
+    selectRep $ do
+      provideRep $ do
+        defaultLayout $ do
+            setTitle $ toHtml $ snapshotTitle snapshot
+            $(widgetFile "stackage-home")
+      provideRep $ pure $ toJSON $ SnapshotInfo snapshot packages
+
+
   where strip x = fromMaybe x (stripSuffix "." x)
 
+data SnapshotInfo
+  = SnapshotInfo { snapshot :: Snapshot
+                 , packages :: [PackageListingInfo]
+                 }
+instance ToJSON SnapshotInfo where
+  toJSON SnapshotInfo{..} = object [ "snapshot" .= snapshot
+                                   , "packages" .= packages
+                                   ]
+
 getStackageDiffR :: SnapName -> SnapName -> Handler TypedContent
 getStackageDiffR name1 name2 = do
     Entity sid1 _ <- lookupSnapshot name1 >>= maybe notFound return
diff --git a/Stackage/Database.hs b/Stackage/Database.hs
index d1d9c54..a6ef073 100644
--- a/Stackage/Database.hs
+++ b/Stackage/Database.hs
@@ -129,6 +129,13 @@ Deprecated
     UniqueDeprecated package
 |]
 
+instance A.ToJSON Snapshot where
+  toJSON Snapshot{..} =
+    A.object [ "name"    A..= snapshotName
+             , "ghc"     A..= snapshotGhc
+             , "created" A..= formatTime defaultTimeLocale "%F" snapshotCreated
+             ]
+
 _hideUnusedWarnings
     :: ( SnapshotPackageId
        , SchemaId
@@ -490,6 +497,14 @@ data PackageListingInfo = PackageListingInfo
     , pliIsCore :: !Bool
     }
 
+instance A.ToJSON PackageListingInfo where
+   toJSON PackageListingInfo{..} =
+       A.object [ "name"     A..= pliName
+                , "version"  A..= pliVersion
+                , "synopsis" A..= pliSynopsis
+                , "isCore"   A..= pliIsCore
+                ]
+
 getPackages :: GetStackageDatabase m => SnapshotId -> m [PackageListingInfo]
 getPackages sid = liftM (map toPLI) $ run $ do
     E.select $ E.from $ \(p,sp) -> do
diff --git a/Stackage/Database/Types.hs b/Stackage/Database/Types.hs
index 19a8f56..f63d45b 100644
--- a/Stackage/Database/Types.hs
+++ b/Stackage/Database/Types.hs
@@ -26,6 +26,9 @@ isNightly SNNightly{} = True
 instance ToJSONKey SnapName where
     toJSONKey = toPathPiece
 
+instance ToJSON SnapName where
+    toJSON = String . toPathPiece
+
 instance PersistField SnapName where
     toPersistValue = toPersistValue . toPathPiece
     fromPersistValue v = do