From 10c9d8364d0c099d611b02d25620d417e7519362 Mon Sep 17 00:00:00 2001
From: Bryan Richter <bryan@haskell.foundation>
Date: Thu, 10 Jul 2025 09:52:25 +0300
Subject: [PATCH] Split JSON API out of /snapshots

Fixes #355
---
 config/routes                  |  1 +
 src/Handler/Snapshots.hs       | 86 ++++++++++++++++++++++++----------
 src/Import.hs                  |  4 +-
 templates/all-snapshots.hamlet | 10 ++--
 4 files changed, 71 insertions(+), 30 deletions(-)

diff --git a/config/routes b/config/routes
index be20a08..7728fd0 100644
--- a/config/routes
+++ b/config/routes
@@ -13,6 +13,7 @@
 
 /snapshot/#Text/*Texts OldSnapshotR GET
 
+/api/v1/snapshots ApiV1SnapshotsR GET
 /api/v1/snapshot/#ApiSnapshotName ApiV1SnapshotR GET
 
 !/#SnapName SnapshotR:
diff --git a/src/Handler/Snapshots.hs b/src/Handler/Snapshots.hs
index b4d2cc7..9be6659 100644
--- a/src/Handler/Snapshots.hs
+++ b/src/Handler/Snapshots.hs
@@ -3,8 +3,11 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NoFieldSelectors #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE FlexibleContexts #-}
 
-module Handler.Snapshots where
+module Handler.Snapshots (getAllSnapshotsR, getApiV1SnapshotsR) where
 
 import RIO.Time
 import Import
@@ -13,41 +16,74 @@ import Stackage.Database
 snapshotsPerPage :: Integral a => a
 snapshotsPerPage = 50
 
--- This is a handler function for the GET request method on the HomeR
--- resource pattern. All of your resource patterns are defined in
--- config/routes
---
--- The majority of the code you will write in Yesod lives in these handler
--- functions. You can spread them across multiple files if you are so
--- inclined, or create a single monolithic file.
-getAllSnapshotsR :: Handler TypedContent
-getAllSnapshotsR = track "Handler.Snapshots.getAllSnapshotsR" $ do
+-- | Extracted from an earlier implementation that just used a big tuple.
+data SnapshotInfo = SnapshotInfo
+    { name :: SnapName
+    , title :: Text
+    , prettyDate :: Text
+    } deriving (Eq, Show)
+
+instance ToJSON SnapshotInfo where
+    toJSON (SnapshotInfo name title prettyDate) =
+        array
+            [ toJSON name
+            , toJSON title
+            , toJSON prettyDate
+            ]
+
+-- | Extracted from an earlier implementation that just used a big tuple.
+data Paging = Paging
+    { totalCount :: Int
+    , currentPage :: Int
+    , isFirstPage :: Bool
+    , isLastPage :: Bool
+    } deriving (Eq, Show)
+
+-- | Fetch snapshot data from the DB that is used in these routes.
+fetchSnapshots :: Handler ([[SnapshotInfo]], Paging)
+fetchSnapshots = do
     cacheSeconds $ 60 * 60 * 6
-    now' <- getCurrentTime
+
     currentPageMay <- lookupGetParam "page"
     let currentPage :: Int
         currentPage = fromMaybe 1 (currentPageMay >>= readMay)
+
     totalCount <- countSnapshots Nothing
-    (map entityVal -> snapshots) <-
-        getSnapshots Nothing snapshotsPerPage
-                             ((fromIntegral currentPage - 1) * snapshotsPerPage)
+
+    snapshots <- map entityVal <$>
+        getSnapshots
+            Nothing
+            snapshotsPerPage
+            ((fromIntegral currentPage - 1) * snapshotsPerPage)
+
+    now' <- getCurrentTime
     let groups = groupUp now' snapshots
 
     let isFirstPage = currentPage == 1
         isLastPage = currentPage * snapshotsPerPage >= totalCount
 
-    selectRep $ do
-      provideRep $ defaultLayout $ do
+    pure (groups, Paging totalCount currentPage isFirstPage isLastPage)
+
+  where uncrapify now' snapshot =
+            SnapshotInfo
+                (snapshotName snapshot)
+                (snapshotTitle snapshot)
+                (dateDiff now' (snapshotCreated snapshot))
+        groupUp now' = groupBy (on (==) (.prettyDate))
+                     . map (uncrapify now')
+
+getAllSnapshotsR :: Handler Html
+getAllSnapshotsR = track "Handler.Snapshots.getAllSnapshotsR" $ do
+    (groups, Paging _ currentPage isFirstPage isLastPage) <- fetchSnapshots
+    defaultLayout $ do
         setTitle "Stackage Server"
         let snapshotsNav = $(widgetFile "snapshots-nav")
         $(widgetFile "all-snapshots")
 
-      provideRep $ return $ object ["snapshots" .= groups, "totalCount" .= totalCount]
-
-  where uncrapify now' snapshot =
-            ( snapshotName snapshot
-            , snapshotTitle snapshot
-            , dateDiff now' (snapshotCreated snapshot)
-            )
-        groupUp now' = groupBy (on (==) (\(_,_,uploaded) -> uploaded))
-                     . map (uncrapify now')
+getApiV1SnapshotsR :: Handler Value
+getApiV1SnapshotsR = track "Handler.API.getApiV1SnapshotsR" $ do
+    (groups, paging) <- fetchSnapshots
+    pure $ object
+        [ "snapshots" .= groups
+        , "totalCount" .= paging.totalCount
+        ]
diff --git a/src/Import.hs b/src/Import.hs
index 67e1dc4..ab8250c 100644
--- a/src/Import.hs
+++ b/src/Import.hs
@@ -67,10 +67,10 @@ track name inner = do
 
 dateDiff :: UTCTime -- ^ now
          -> Day -- ^ target
-         -> LText
+         -> Text
 dateDiff (UTCTime now' _) target
     | now' == target = "today"
-    | otherwise = format (diff True) $ diffUTCTime
+    | otherwise = toStrict $ format (diff True) $ diffUTCTime
         (UTCTime target 0)
         (UTCTime now' 0)
 
diff --git a/templates/all-snapshots.hamlet b/templates/all-snapshots.hamlet
index 0207a77..dd8b53a 100644
--- a/templates/all-snapshots.hamlet
+++ b/templates/all-snapshots.hamlet
@@ -1,13 +1,17 @@
 <div .container>
     <div .content>
         <h1>Snapshots
+        <p>
+            Looking for
+            <a href=@{ApiV1SnapshotsR}>
+              this data as JSON?
         ^{snapshotsNav}
         $forall stackages <- groups
-            $forall (_, _, uploaded) <- take 1 stackages
+            $forall groupLeader <- take 1 stackages
                 <h3>
-                    #{uploaded}
+                    #{groupLeader.prettyDate}
             <ul .snapshots>
-                $forall (ident, title, _uploaded) <- stackages
+                $forall SnapshotInfo ident title _ <- stackages
                     <li>
                         <strong>
                             <a href=@{SnapshotR ident StackageHomeR}>