From f5dac7092f6ba8689621b93c222235ccc00f28b1 Mon Sep 17 00:00:00 2001
From: Bryan Richter <bryan@haskell.foundation>
Date: Thu, 19 Jun 2025 10:33:38 +0300
Subject: [PATCH] Accept snapshot branches at /api/v1/snapshot

---
 config/routes                     |  2 +-
 src/Foundation.hs                 |  1 +
 src/Handler/StackageHome.hs       | 16 +++++++++++++---
 src/Handler/StackageHome/Types.hs | 21 +++++++++++++++++++++
 4 files changed, 36 insertions(+), 4 deletions(-)
 create mode 100644 src/Handler/StackageHome/Types.hs

diff --git a/config/routes b/config/routes
index 24b30d2..be20a08 100644
--- a/config/routes
+++ b/config/routes
@@ -13,7 +13,7 @@
 
 /snapshot/#Text/*Texts OldSnapshotR GET
 
-/api/v1/snapshot/#SnapName ApiV1SnapshotR GET
+/api/v1/snapshot/#ApiSnapshotName ApiV1SnapshotR GET
 
 !/#SnapName SnapshotR:
     / StackageHomeR GET
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 4bac6d6..576b358 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -11,6 +11,7 @@ import Data.WebsiteContent
 import Settings
 import Settings.StaticFiles
 import Stackage.Database
+import Handler.StackageHome.Types (ApiSnapshotName(..))
 import Text.Hamlet (hamletFile)
 import Types
 import Yesod.AtomFeed
diff --git a/src/Handler/StackageHome.hs b/src/Handler/StackageHome.hs
index 41bd7ec..25dce73 100644
--- a/src/Handler/StackageHome.hs
+++ b/src/Handler/StackageHome.hs
@@ -14,14 +14,24 @@ module Handler.StackageHome
     ) where
 
 import Data.These
+import Handler.StackageHome.Types (ApiSnapshotName(..))
+import Import
 import RIO (textDisplay)
 import RIO.Time (FormatTime)
-import Import
 import Stackage.Database
 import Stackage.Snapshot.Diff
 
-getApiV1SnapshotR :: SnapName -> Handler Value
-getApiV1SnapshotR name = track "Handler.StackageHome.getApiV1SnapshotR" $ do
+-- | Return JSON representation of a snapshot.
+-- Redirect /lts, /nightly, /lts-X to the latest corresponding full snapshot.
+getApiV1SnapshotR :: ApiSnapshotName -> Handler Value
+getApiV1SnapshotR (ApiSnapshotNameBranch branch) = track "Handler.API.getApiV1SnapshotR.Branch" $ do
+    mLatestSnap <- case branch of
+        LtsBranch -> fmap (uncurry SNLts) <$> newestLTS
+        LtsMajorBranch x -> fmap (SNLts x) <$> newestLTSMajor x
+        NightlyBranch -> fmap SNNightly <$> newestNightly
+    maybe notFound (redirectWith found302 . ApiV1SnapshotR . ApiSnapshotName) mLatestSnap
+
+getApiV1SnapshotR (ApiSnapshotName name) = track "Handler.API.getApiV1SnapshotR.Name" $ do
     Entity sid snapshot <- lookupSnapshot name >>= maybe notFound return
     packages <- getPackagesForSnapshot sid
     pure $ toJSON $ SnapshotInfo snapshot packages
diff --git a/src/Handler/StackageHome/Types.hs b/src/Handler/StackageHome/Types.hs
new file mode 100644
index 0000000..487e2a8
--- /dev/null
+++ b/src/Handler/StackageHome/Types.hs
@@ -0,0 +1,21 @@
+module Handler.StackageHome.Types (
+    ApiSnapshotName(..),
+) where
+
+import ClassyPrelude.Yesod
+import Types
+
+-- | Combining SnapshotBranch and SnapName. Prevents needing overlapping routes
+-- for /api/v1/snapshot, unlike how SnapshotR and OldSnashotBranchR work.
+data ApiSnapshotName
+    = ApiSnapshotName SnapName
+    | ApiSnapshotNameBranch SnapshotBranch
+    deriving (Eq, Show, Read)
+
+instance PathPiece ApiSnapshotName where
+    fromPathPiece x =
+        ApiSnapshotName <$> fromPathPiece x
+        <|> ApiSnapshotNameBranch <$> fromPathPiece x
+
+    toPathPiece (ApiSnapshotName name) = toPathPiece name
+    toPathPiece (ApiSnapshotNameBranch branch) = toPathPiece branch