From 113d4dfb432c63bc829e27d417058c9f86ddcf64 Mon Sep 17 00:00:00 2001
From: Vladimir Nikishkin <>
Date: Thu, 26 Oct 2023 13:11:23 +0800
Subject: [PATCH] Allow serving cabal files with package name in the file name.

Allow serving url like this:
https://hackage.haskell.org/package/pkg-2.6/revision/pkg-2.6-1.cabal
---
 datafiles/templates/Html/revisions.html.st |  2 +-
 src/Distribution/Server/Features/Core.hs   | 22 ++++++++++++++++++++++
 2 files changed, 23 insertions(+), 1 deletion(-)

diff --git a/datafiles/templates/Html/revisions.html.st b/datafiles/templates/Html/revisions.html.st
index 69cf2b75a..98c875c29 100644
--- a/datafiles/templates/Html/revisions.html.st
+++ b/datafiles/templates/Html/revisions.html.st
@@ -25,7 +25,7 @@ stored separately.
   </tr>
   $revisions:{revision|
     <tr>
-      <td valign="top"><a href="/package/$pkgid$/revision/$revision.number$.cabal">-r$revision.number$</a></td>
+      <td valign="top"><a href="/package/$pkgid$/revision/$revision.number$.cabal">-r$revision.number$</a> (<a href="/package/$pkgid$/revision/$pkgid$-$revision.number$.cabal">$pkgid$-r$revision.number$</a>)</td>
       <td valign="top">$revision.htmltime$</td>
       <td valign="top"><a href="/user/$revision.user$">$revision.user$</td>
       <td valign="top">$revision.sha256$</th>
diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs
index 6aec793ab..e32e247e2 100644
--- a/src/Distribution/Server/Features/Core.hs
+++ b/src/Distribution/Server/Features/Core.hs
@@ -225,6 +225,7 @@ data CoreResource = CoreResource {
     corePackageTarball  :: Resource,
     -- | A Cabal file metatada revision.
     coreCabalFileRev    :: Resource,
+    coreCabalFileRevName    :: Resource,
 
     -- Rendering resources.
     -- | URI for `corePackagesPage`, given a format (blank for none).
@@ -403,6 +404,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
           , coreCabalFile
           , coreCabalFileRevs
           , coreCabalFileRev
+          , coreCabalFileRevName
           , coreUserDeauth
           , coreAdminDeauth
           , corePackUserDeauth
@@ -456,6 +458,11 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
         resourceDesc = [(GET, "Get package .cabal file revision")]
       , resourceGet  = [("cabal", serveCabalFileRevision)]
       }
+    coreCabalFileRevName = (resourceAt "/package/:package/revision/:tarball-:revision.:format") {
+        resourceDesc = [(GET, "Get package .cabal file revision with name")]
+      , resourceGet  = [("cabal", serveCabalFileRevisionName)]
+      }
+
 
     coreUserDeauth = (resourceAt "/packages/deauth") {
         resourceDesc = [(GET,  "Deauth Package user")]
@@ -750,6 +757,21 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
         Nothing -> errNotFound "Package revision not found"
                      [MText "Cannot parse revision, or revision out of range."]
 
+    serveCabalFileRevisionName :: DynamicPath -> ServerPartE Response
+    serveCabalFileRevisionName dpath = do
+      pkgid1 <- packageTarballInPath dpath
+      pkgid2 <- packageInPath dpath
+      guard (pkgVersion pkgid2 == pkgVersion pkgid2)
+      pkginfo <- packageInPath dpath >>= lookupPackageId
+      let mrev      = lookup "revision" dpath >>= fromReqURI
+          revisions = pkgMetadataRevisions pkginfo
+      case mrev >>= \rev -> revisions Vec.!? rev of
+        Just (fileRev, (utime, _uid)) -> return $ toResponse cabalfile
+          where
+            cabalfile = Resource.CabalFile (cabalFileByteString fileRev) utime
+        Nothing -> errNotFound "Package revision not found"
+                     [MText "Cannot parse revision, or revision out of range."]
+
 
     deauth :: DynamicPath -> ServerPartE Response
     deauth _ = do