Package pages per snapshot

This allows us to replace the Haddock-generate contents pages with our
snapshot/package pages.

Handler/HackageViewSdist.hs

@@ -5,7 +5,7 @@ import Data.Hackage
 import Handler.StackageSdist (addDownload)
 
 getHackageViewSdistR :: HackageView -> PackageNameVersion -> Handler TypedContent
-getHackageViewSdistR viewName (PackageNameVersion name version) = do
+getHackageViewSdistR viewName (PNVTarball name version) = do
     addDownload Nothing (Just viewName) name version
     msrc <- sourceHackageViewSdist viewName name version
     case msrc of
@@ -19,3 +19,4 @@ getHackageViewSdistR viewName (PackageNameVersion name version) = do
                 , ".tar.gz"
                 ]
             respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src
+getHackageViewSdistR _ _ = notFound

Handler/Haddock.hs

@@ -61,7 +61,12 @@ getHaddockR slug rest = do
     ident <- runDB $ do
         ment <- getBy $ UniqueSnapshot slug
         case ment of
-            Just ent -> return $ stackageIdent $ entityVal ent
+            Just ent -> do
+                case rest of
+                    [pkgver] -> tryContentsRedirect ent pkgver
+                    [pkgver, "index.html"] -> tryContentsRedirect ent pkgver
+                    _ -> return ()
+                return $ stackageIdent $ entityVal ent
             Nothing -> do
                 Entity _ stackage <- getBy404
                                   $ UniqueStackage
@@ -98,6 +103,27 @@ getHaddockR slug rest = do
             permissionDenied "Invalid request"
         | otherwise = return ()
 
+-- | Try to redirect to the snapshot's package page instead of the
+-- Haddock-generated HTML.
+tryContentsRedirect :: Entity Stackage -> Text -> YesodDB App ()
+tryContentsRedirect (Entity sid Stackage {..}) pkgver = do
+    mdocs <- selectFirst
+        [ DocsName ==. name
+        , DocsVersion ==. version
+        , DocsSnapshot ==. Just sid
+        ]
+        []
+    forM_ mdocs $ const
+         $ redirect
+         $ SnapshotR stackageSlug
+         $ StackageSdistR
+         $ PNVNameVersion name version
+  where
+    (PackageName . dropDash -> name, Version -> version) = T.breakOnEnd "-" pkgver
+
+dropDash :: Text -> Text
+dropDash t = fromMaybe t $ stripSuffix "-" t
+
 getHaddockDir :: PackageSetIdent -> Handler (FilePath, FilePath)
 getHaddockDir ident = do
     master <- getYesod
@@ -314,7 +340,7 @@ getUploadDocMapR = do
         <*> areq textField "Stackage ID" { fsName = Just "snapshot" } Nothing
     case res of
         FormSuccess (fi, snapshot) -> do
-            Entity _sid stackage <- runDB $ do
+            Entity sid stackage <- runDB $ do
                 ment <- getBy $ UniqueStackage $ PackageSetIdent snapshot
                 case ment of
                     Just ent -> return ent
@@ -330,7 +356,12 @@ getUploadDocMapR = do
                     now <- liftIO getCurrentTime
                     render <- getUrlRender
                     runDB $ forM_ (mapToList $ asMap m0) $ \(package, DocInfo version ms) -> do
-                        did <- insert $ Docs (PackageName package) version now
+                        did <- insert Docs
+                            { docsName = PackageName package
+                            , docsVersion = version
+                            , docsUploaded = now
+                            , docsSnapshot = Just sid
+                            }
                         forM_ (mapToList ms) $ \(name, pieces) -> do
                             let url = render $ HaddockR (stackageSlug stackage) pieces
                             insert_ $ Module did name url

Handler/Package.hs

@@ -21,7 +21,14 @@ import           Text.Email.Validate
 
 -- | Page metadata package.
 getPackageR :: PackageName -> Handler Html
-getPackageR pn = do
+getPackageR pn =
+    packagePage pn Nothing (selectFirst [DocsName ==. pn] [Desc DocsUploaded])
+
+packagePage :: PackageName
+            -> Maybe Version
+            -> YesodDB App (Maybe (Entity Docs))
+            -> Handler Html
+packagePage pn mversion getDocs = do
     let haddocksLink ident version =
             HaddockR ident [concat [toPathPiece pn, "-", toPathPiece version]]
     muid <- maybeAuthId
@@ -37,8 +44,8 @@ getPackageR pn = do
 
         metadata <- getBy404 (UniqueMetadata pn)
         revdeps' <- reverseDeps pn
-        mdocsent <- selectFirst [DocsName ==. pn] [Desc DocsUploaded]
+        mdocsent <- getDocs
-        mdocs <- forM mdocsent $ \(Entity docsid (Docs _ version _)) -> (,)
+        mdocs <- forM mdocsent $ \(Entity docsid (Docs _ version _ _)) -> (,)
             <$> pure version
             <*> (map entityVal <$>
                  selectList [ModuleDocs ==. docsid] [Asc ModuleName])
@@ -56,6 +63,7 @@ getPackageR pn = do
                )
 
     let ixInFavourOf = zip [0::Int ..] inFavourOf
+        displayedVersion = fromMaybe (metadataVersion metadata) mversion
 
     myTags <- maybe (return []) (runDB . user'sTagsOf pn) muid
     tags <- fmap (map (\(v,count') -> (v,count',any (==v) myTags)))

Handler/StackageSdist.hs

@@ -4,9 +4,10 @@ import Import
 import Data.BlobStore
 import Data.Hackage
 import Data.Slug (SnapSlug)
+import Handler.Package (packagePage)
 
 getStackageSdistR :: SnapSlug -> PackageNameVersion -> Handler TypedContent
-getStackageSdistR slug (PackageNameVersion name version) = do
+getStackageSdistR slug (PNVTarball name version) = do
     Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug
     let ident = stackageIdent stackage
     addDownload (Just ident) Nothing name version
@@ -26,6 +27,27 @@ getStackageSdistR slug (PackageNameVersion name version) = do
                 , ".tar.gz"
                 ]
             respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src
+getStackageSdistR slug (PNVName name) = runDB $ do
+    Entity sid _ <- getBy404 $ UniqueSnapshot slug
+    mp <- selectFirst
+        [PackageStackage ==. sid, PackageName' ==. name]
+        [Desc PackageVersion]
+    case mp of
+        Nothing -> notFound
+        Just (Entity _ Package {..}) ->
+            redirect $ SnapshotR slug
+                     $ StackageSdistR
+                     $ PNVNameVersion name packageVersion
+getStackageSdistR slug (PNVNameVersion name version) = packagePage
+  name (Just version)
+  (do
+    Entity sid _ <- getBy404 $ UniqueSnapshot slug
+    selectFirst
+        [ DocsName ==. name
+        , DocsVersion ==. version
+        , DocsSnapshot ==. Just sid
+        ]
+        []) >>= sendResponse
 
 addDownload :: Maybe PackageSetIdent
             -> Maybe HackageView

Types.hs

@@ -23,17 +23,31 @@ newtype HackageView = HackageView { unHackageView :: Text }
 instance PersistFieldSql HackageView where
     sqlType = sqlType . liftM unHackageView
 
-data PackageNameVersion = PackageNameVersion !PackageName !Version
+data PackageNameVersion = PNVTarball !PackageName !Version
+                        | PNVNameVersion !PackageName !Version
+                        | PNVName !PackageName
     deriving (Show, Read, Typeable, Eq, Ord)
 
 instance PathPiece PackageNameVersion where
-    toPathPiece (PackageNameVersion x y) = concat [toPathPiece x, "-", toPathPiece y, ".tar.gz"]
+    toPathPiece (PNVTarball x y) = concat [toPathPiece x, "-", toPathPiece y, ".tar.gz"]
+    toPathPiece (PNVNameVersion x y) = concat [toPathPiece x, "-", toPathPiece y]
+    toPathPiece (PNVName x) = toPathPiece x
     fromPathPiece t' | Just t <- stripSuffix ".tar.gz" t' =
         case T.breakOnEnd "-" t of
             ("", _) -> Nothing
             (_, "") -> Nothing
-            (T.init -> name, version) -> Just $ PackageNameVersion (PackageName name) (Version version)
+            (T.init -> name, version) -> Just $ PNVTarball (PackageName name) (Version version)
-    fromPathPiece _ = Nothing
+    fromPathPiece t = Just $
+        case T.breakOnEnd "-" t of
+            ("", _) -> PNVName (PackageName t)
+            (T.init -> name, version) | validVersion version ->
+                PNVNameVersion (PackageName name) (Version version)
+            _ -> PNVName (PackageName t)
+      where
+        validVersion =
+            all f
+          where
+            f c = (c == '.') || ('0' <= c && c <= '9')
 
 data StoreKey = HackageCabal !PackageName !Version
               | HackageSdist !PackageName !Version

config/models

@@ -93,6 +93,7 @@ Docs
     name PackageName
     version Version
     uploaded UTCTime
+    snapshot StackageId Maybe
 Module
     docs DocsId
     name Text

templates/package.hamlet

@@ -17,7 +17,7 @@ $newline never
             <h1>
                #{pn} #
                <span .latest-version>
-                 #{metadataVersion metadata} #
+                 #{displayedVersion} #
             <p .synopsis>
                 #{synopsis}
                \ #

templates/stackage-home.hamlet

@@ -58,10 +58,13 @@ $newline never
                 $forall (name,mversion,synopsis,mdoc) <- packages
                     <tr>
                         <td>
-                            <a href=@{PackageR name}>
+                            $maybe version <- mversion
-                                #{name}
+                                <a href=@{SnapshotR slug $ StackageSdistR $ PNVNameVersion name $ Version version}>
-                                $maybe version <- mversion
+                                    #{name}
                                     -#{asText version}
+                            $nothing
+                                <a href=@{SnapshotR slug $ StackageSdistR $ PNVName name}>
+                                    #{name}
                         <td>
                             $maybe doc <- mdoc
                                 <a href=@{doc}>Docs