From 7ac0fd8dbc679177108f8037a11b35656986d215 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 24 Dec 2014 08:44:52 +0200 Subject: [PATCH] Package pages per snapshot This allows us to replace the Haddock-generate contents pages with our snapshot/package pages. --- Handler/HackageViewSdist.hs | 3 ++- Handler/Haddock.hs | 37 +++++++++++++++++++++++++++++++--- Handler/Package.hs | 14 ++++++++++--- Handler/StackageSdist.hs | 24 +++++++++++++++++++++- Types.hs | 22 ++++++++++++++++---- config/models | 1 + templates/package.hamlet | 2 +- templates/stackage-home.hamlet | 9 ++++++--- 8 files changed, 96 insertions(+), 16 deletions(-) diff --git a/Handler/HackageViewSdist.hs b/Handler/HackageViewSdist.hs index 0351d99..e5dbb0c 100644 --- a/Handler/HackageViewSdist.hs +++ b/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 diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index 0eaa82d..e4c4767 100644 --- a/Handler/Haddock.hs +++ b/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 diff --git a/Handler/Package.hs b/Handler/Package.hs index b2a843c..3e10303 100644 --- a/Handler/Package.hs +++ b/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] - mdocs <- forM mdocsent $ \(Entity docsid (Docs _ version _)) -> (,) + mdocsent <- getDocs + 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))) diff --git a/Handler/StackageSdist.hs b/Handler/StackageSdist.hs index 28c2d19..c738d47 100644 --- a/Handler/StackageSdist.hs +++ b/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 diff --git a/Types.hs b/Types.hs index 9b5e135..ea3f58a 100644 --- a/Types.hs +++ b/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) - fromPathPiece _ = Nothing + (T.init -> name, version) -> Just $ PNVTarball (PackageName name) (Version version) + 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 diff --git a/config/models b/config/models index 8b555c8..177b3d2 100644 --- a/config/models +++ b/config/models @@ -93,6 +93,7 @@ Docs name PackageName version Version uploaded UTCTime + snapshot StackageId Maybe Module docs DocsId name Text diff --git a/templates/package.hamlet b/templates/package.hamlet index 322bf89..8ee3401 100644 --- a/templates/package.hamlet +++ b/templates/package.hamlet @@ -17,7 +17,7 @@ $newline never

#{pn} # - #{metadataVersion metadata} # + #{displayedVersion} #

#{synopsis} \ # diff --git a/templates/stackage-home.hamlet b/templates/stackage-home.hamlet index 854e178..671c45a 100644 --- a/templates/stackage-home.hamlet +++ b/templates/stackage-home.hamlet @@ -58,10 +58,13 @@ $newline never $forall (name,mversion,synopsis,mdoc) <- packages - - #{name} - $maybe version <- mversion + $maybe version <- mversion + + #{name} -#{asText version} + $nothing + + #{name} $maybe doc <- mdoc Docs