Add an unversioned package doc redirect

That is /package/foo/docs/blah.html -> /package/foo-1.0/docs/blah.html Using a temp redirect to whatever is the latest version. Fixes issue #61
haskell · Sep 19, 2013 · 5f311f1 · 5f311f1
1 parent d814748
commit 5f311f1
Show file tree

Hide file tree

Showing 7 changed files with 60 additions and 33 deletions.
diff --git a/Distribution/Server/Features/Core.hs b/Distribution/Server/Features/Core.hs
@@ -72,11 +72,7 @@ data CoreFeature = CoreFeature {
     packageChangeHook :: Hook PackageChange (),
 
     -- | Notification of downloads
-    packageDownloadHook :: Hook PackageId (),
-
-    -- Find a package in the package DB
-    lookupPackageName :: PackageName -> ServerPartE [PkgInfo],
-    lookupPackageId   :: PackageId   -> ServerPartE PkgInfo
+    packageDownloadHook :: Hook PackageId ()
 }
 
 instance IsHackageFeature CoreFeature where
@@ -137,7 +133,11 @@ data CoreResource = CoreResource {
 
     -- Check that a package exists (guard fails if version is empty)
     guardValidPackageId   :: PackageId   -> ServerPartE (),
-    guardValidPackageName :: PackageName -> ServerPartE ()
+    guardValidPackageName :: PackageName -> ServerPartE (),
+
+    -- Find a package in the package DB
+    lookupPackageName :: PackageName -> ServerPartE [PkgInfo],
+    lookupPackageId   :: PackageId   -> ServerPartE PkgInfo
 }
 
 initCoreFeature :: ServerEnv -> UserFeature -> IO CoreFeature

diff --git a/Distribution/Server/Features/Documentation.hs b/Distribution/Server/Features/Documentation.hs
@@ -21,6 +21,7 @@ import Data.TarIndex (TarIndex)
 
 import Distribution.Text
 import Distribution.Package
+import Distribution.Version (Version(..))
 
 import qualified Data.Map as Map
 import Data.Function (fix)
@@ -117,6 +118,7 @@ documentationFeature name
                        , guardValidPackageId
                        , corePackagePage
                        , corePackagesPage
+                       , lookupPackageId
                        }
                      getPackages
                      UploadFeature{..}
@@ -170,15 +172,17 @@ documentationFeature name
 
     serveDocumentationTar :: DynamicPath -> ServerPartE Response
     serveDocumentationTar dpath =
-      withDocumentation dpath $ \_ blob _ -> do
+      withDocumentation (packageDocsWhole documentationResource)
+                        dpath $ \_ blob _ -> do
         file <- liftIO $ BlobStorage.fetch store blob
         return $ toResponse $ Resource.DocTarball file blob
 
 
     -- return: not-found error or tarball
     serveDocumentation :: DynamicPath -> ServerPartE Response
     serveDocumentation dpath = do
-      withDocumentation dpath $ \pkgid blob index -> do
+      withDocumentation (packageDocsContent documentationResource)
+                        dpath $ \pkgid blob index -> do
         let tarball = BlobStorage.filepath store blob
             etag    = blobETag blob
         -- if given a directory, the default page is index.html
@@ -228,16 +232,30 @@ documentationFeature name
         ..
    -}
 
-    withDocumentation :: DynamicPath -> (PackageId -> BlobId -> TarIndex -> ServerPartE a) -> ServerPartE a
-    withDocumentation dpath func = do
+    withDocumentation :: Resource -> DynamicPath
+                      -> (PackageId -> BlobId -> TarIndex -> ServerPartE Response)
+                      -> ServerPartE Response
+    withDocumentation self dpath func = do
       pkgid <- packageInPath dpath
-      guardValidPackageId pkgid
-      mdocs <- queryState documentationState $ LookupDocumentation pkgid
-      case mdocs of
-        Nothing -> errNotFound "Not Found" [MText $ "There is no documentation for " ++ display pkgid]
-        Just blob -> do
-          index <- liftIO $ cachedTarIndex blob
-          func pkgid blob index
+      -- lookupPackageId gives us the latest version if no version is specified:
+      pkginfo <- lookupPackageId pkgid
+      case pkgVersion pkgid of
+        -- if no version is given we want to redirect to the latest version
+        Version [] _ -> tempRedirect (renderResource' self dpath') (toResponse "")
+          where
+            latest = packageId pkginfo
+            dpath' = [ if var == "package"
+                         then (var, display latest)
+                         else e
+                     | e@(var, _) <- dpath ]
+        _ -> do
+          mdocs <- queryState documentationState $ LookupDocumentation pkgid
+          case mdocs of
+            Nothing -> errNotFound "Not Found"
+                         [MText $ "There is no documentation for " ++ display pkgid]
+            Just blob -> do
+              index <- liftIO $ cachedTarIndex blob
+              func pkgid blob index
 
 {------------------------------------------------------------------------------
   Auxiliary

diff --git a/Distribution/Server/Features/EditCabalFiles.hs b/Distribution/Server/Features/EditCabalFiles.hs
@@ -59,7 +59,8 @@ editCabalFilesFeature :: ServerEnv -> Templates
                       -> UserFeature -> CoreFeature -> UploadFeature
                       -> HackageFeature
 editCabalFilesFeature _env templates
-                      UserFeature{guardAuthorised} CoreFeature{..}
+                      UserFeature{guardAuthorised}
+                      CoreFeature{..}
                       UploadFeature{maintainersGroup, trusteesGroup} =
   (emptyHackageFeature "edit-cabal-files") {
     featureResources =
@@ -69,6 +70,7 @@ editCabalFilesFeature _env templates
   }
 
   where
+    CoreResource{..} = coreResource
     editCabalFileResource =
       (resourceAt "/package/:package/:cabal.cabal/edit")  {
         resourceDesc = [(GET,  "Page to edit package metadata")
@@ -80,7 +82,7 @@ editCabalFilesFeature _env templates
     serveEditCabalFileGet :: DynamicPath -> ServerPartE Response
     serveEditCabalFileGet dpath = do
         template <- getTemplate templates "cabalFileEditPage.html"
-        pkg <- packageInPath coreResource dpath >>= lookupPackageId
+        pkg <- packageInPath dpath >>= lookupPackageId
         let pkgname = packageName pkg
             pkgid   = packageId pkg
         -- check that the cabal name matches the package
@@ -94,7 +96,7 @@ editCabalFilesFeature _env templates
     serveEditCabalFilePost :: DynamicPath -> ServerPartE Response
     serveEditCabalFilePost dpath = do
         template <- getTemplate templates "cabalFileEditPage.html"
-        pkg <- packageInPath coreResource dpath >>= lookupPackageId
+        pkg <- packageInPath dpath >>= lookupPackageId
         let pkgname = packageName pkg
             pkgid   = packageId pkg
         -- check that the cabal name matches the package

diff --git a/Distribution/Server/Features/Html.hs b/Distribution/Server/Features/Html.hs
@@ -398,7 +398,7 @@ mkHtmlCore :: HtmlUtilities
            -> Templates
            -> HtmlCore
 mkHtmlCore HtmlUtilities{..}
-           CoreFeature{lookupPackageName,coreResource}
+           CoreFeature{coreResource}
            VersionsFeature{ versionsResource
                           , queryGetDeprecatedFor
                           , queryGetPreferredInfo
@@ -417,7 +417,7 @@ mkHtmlCore HtmlUtilities{..}
            templates
   = HtmlCore{..}
   where
-    cores@CoreResource{packageInPath} = coreResource
+    cores@CoreResource{packageInPath, lookupPackageName} = coreResource
     versions = versionsResource
     docs     = documentationResource
 
@@ -929,8 +929,10 @@ mkHtmlPreferred :: HtmlUtilities
                 -> VersionsFeature
                 -> HtmlPreferred
 mkHtmlPreferred HtmlUtilities{..}
-                CoreFeature{ coreResource = CoreResource{packageInPath}
-                           , lookupPackageName
+                CoreFeature{ coreResource = CoreResource{
+                               packageInPath
+                             , lookupPackageName
+                             }
                            }
                 VersionsFeature{..} = HtmlPreferred{..}
   where
@@ -1183,8 +1185,10 @@ mkHtmlTags :: HtmlUtilities
            -> TagsFeature
            -> HtmlTags
 mkHtmlTags HtmlUtilities{..}
-           CoreFeature{ coreResource = CoreResource{packageInPath}
-                      , lookupPackageName
+           CoreFeature{ coreResource = CoreResource{
+                          packageInPath
+                        , lookupPackageName
+                        }
                       }
            ListFeature{makeItemList}
            TagsFeature{..} = HtmlTags{..}

diff --git a/Distribution/Server/Features/Mirror.hs b/Distribution/Server/Features/Mirror.hs
@@ -92,14 +92,15 @@ mirrorFeature :: ServerEnv
               -> (MirrorFeature, UserGroup)
 
 mirrorFeature ServerEnv{serverBlobStore = store}
-              CoreFeature{ coreResource = coreResource@CoreResource{ packageInPath
-                                                                   , packageTarballInPath
-                                                                   }
+              CoreFeature{ coreResource = coreResource@CoreResource{
+                             packageInPath
+                           , packageTarballInPath
+                           , lookupPackageId
+                           }
                          , updateAddPackageRevision
                          , updateAddPackageTarball
                          , updateSetPackageUploadTime
                          , updateSetPackageUploader
-                         , lookupPackageId
                          }
               UserFeature{..}
               mirrorersState mirrorGroup mirrorGroupResource

diff --git a/Distribution/Server/Features/PackageContents.hs b/Distribution/Server/Features/PackageContents.hs
@@ -59,8 +59,10 @@ packageContentsFeature :: ServerEnv
                        -> PackageContentsFeature
 
 packageContentsFeature ServerEnv{serverBlobStore = store}
-                       CoreFeature{ coreResource = CoreResource{packageInPath}
-                                  , lookupPackageId
+                       CoreFeature{ coreResource = CoreResource{
+                                      packageInPath
+                                    , lookupPackageId
+                                    }
                                   }
                        TarIndexCacheFeature{cachedPackageTarIndex}
   = PackageContentsFeature{..}

diff --git a/Distribution/Server/Features/PreferredVersions.hs b/Distribution/Server/Features/PreferredVersions.hs
@@ -123,9 +123,9 @@ versionsFeature :: CoreFeature
 
 versionsFeature CoreFeature{ coreResource=CoreResource{ packageInPath
                                                       , guardValidPackageName
+                                                      , lookupPackageName
                                                       }
                            , queryGetPackageIndex
-                           , lookupPackageName
                            , updateArchiveIndexEntry
                            }
                 UploadFeature{..}