Merge pull request #1262 from lockywolf/master

Allow serving cabal files with package name in the file name.
haskell · Dec 4, 2023 · 22b5612 · 22b5612
2 parents 4a14eaf + 113d4df
commit 22b5612
Show file tree

Hide file tree

Showing 2 changed files with 23 additions and 1 deletion.
diff --git 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
@@ -226,6 +226,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).
@@ -404,6 +405,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
           , coreCabalFile
           , coreCabalFileRevs
           , coreCabalFileRev
+          , coreCabalFileRevName
           , coreUserDeauth
           , coreAdminDeauth
           , corePackUserDeauth
@@ -457,6 +459,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")]
@@ -754,6 +761,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