From 522d2228a999645a3f6e66dff89f4e5fcf534abf Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 10 Dec 2014 12:06:55 +0200 Subject: [PATCH] Package page per snapshot #36 #49 This is not yet live. We'll have a link for all packages in each snapshot, which includes the version number, doc link if available, and synopsis. --- Handler/Alias.hs | 3 ++- Handler/Haddock.hs | 11 +++++---- Handler/PackageList.hs | 9 ++++++- Handler/StackageHome.hs | 45 ++++++++++++++++++++++++++++++++++ config/routes | 1 + templates/package-list.hamlet | 11 ++++++++- templates/stackage-home.hamlet | 4 +++ 7 files changed, 76 insertions(+), 8 deletions(-) diff --git a/Handler/Alias.hs b/Handler/Alias.hs index d3ba778..8b4f5f3 100644 --- a/Handler/Alias.hs +++ b/Handler/Alias.hs @@ -6,7 +6,7 @@ module Handler.Alias import Import import Data.Slug (Slug) -import Handler.StackageHome (getStackageHomeR, getStackageMetadataR, getStackageCabalConfigR) +import Handler.StackageHome (getStackageHomeR, getStackageMetadataR, getStackageCabalConfigR, getSnapshotPackagesR) import Handler.StackageIndex (getStackageIndexR, getStackageBundleR) import Handler.StackageSdist (getStackageSdistR) @@ -75,4 +75,5 @@ goSid sid pieces = do StackageIndexR -> getStackageIndexR slug >>= sendResponse StackageBundleR -> getStackageBundleR slug >>= sendResponse StackageSdistR pnv -> getStackageSdistR slug pnv >>= sendResponse + SnapshotPackagesR -> getSnapshotPackagesR slug >>= sendResponse _ -> notFound diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index e1d769b..e67e2ee 100644 --- a/Handler/Haddock.hs +++ b/Handler/Haddock.hs @@ -276,14 +276,15 @@ createHaddockUnpacker root store runDB' = do [PackageStackage ==. sid] [PackageHasHaddocks =. False] sourceDirectory destdir $$ mapM_C (\fp -> do - let mname = stripSuffix "-" - $ fst - $ T.breakOnEnd "-" - $ fpToText - $ filename fp + let (name', version) = + T.breakOnEnd "-" + $ fpToText + $ filename fp + mname = stripSuffix "-" name' forM_ mname $ \name -> updateWhere [ PackageStackage ==. sid , PackageName' ==. PackageName name + , PackageVersion ==. Version version ] [PackageHasHaddocks =. True] ) diff --git a/Handler/PackageList.hs b/Handler/PackageList.hs index d08701a..fbfe44a 100644 --- a/Handler/PackageList.hs +++ b/Handler/PackageList.hs @@ -6,11 +6,17 @@ import qualified Database.Esqueleto as E import Import import Yesod.Core.Types (WidgetT (WidgetT), unWidgetT) +-- FIXME maybe just redirect to the LTS or nightly package list getPackageListR :: Handler Html getPackageListR = defaultLayout $ do setTitle "Package list" cachedWidget (20 * 60) "package-list" $ do - packages <- fmap (uniqueByKey . map (E.unValue***strip . E.unValue)) $ handlerToWidget $ runDB $ + let clean (x, y) = + ( E.unValue x + , strip $ E.unValue y + ) + addDocs (x, y) = (x, Nothing, y, Nothing) + packages <- fmap (map addDocs . uniqueByKey . map clean) $ handlerToWidget $ runDB $ E.selectDistinct $ E.from $ \(u,m) -> do E.where_ (m E.^. MetadataName E.==. u E.^. UploadedName) E.orderBy [E.asc $ u E.^. UploadedName] @@ -19,6 +25,7 @@ getPackageListR = defaultLayout $ do $(widgetFile "package-list") where strip x = fromMaybe x (stripSuffix "." x) uniqueByKey = sortBy (comparing fst) . M.toList . M.fromList + mback = Nothing -- FIXME move somewhere else, maybe even yesod-core cachedWidget :: NominalDiffTime -> Text -> Widget -> Widget diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index d4628ef..f350623 100644 --- a/Handler/StackageHome.hs +++ b/Handler/StackageHome.hs @@ -4,6 +4,8 @@ import Data.BlobStore (storeExists) import Import import Data.Time (FormatTime) import Data.Slug (SnapSlug) +import qualified Database.Esqueleto as E +import Handler.PackageList (cachedWidget) getStackageHomeR :: SnapSlug -> Handler Html getStackageHomeR slug = do @@ -89,3 +91,46 @@ getOldStackageR ident pieces = do case parseRoute ("snapshot" : toPathPiece (stackageSlug stackage) : pieces, []) of Nothing -> notFound Just route -> redirect (route :: Route App) + +getSnapshotPackagesR :: SnapSlug -> Handler Html +getSnapshotPackagesR slug = do + Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug + defaultLayout $ do + setTitle $ toHtml $ "Package list for " ++ toPathPiece slug + cachedWidget (20 * 60) ("package-list-" ++ toPathPiece slug) $ do + packages' <- handlerToWidget $ runDB $ E.select $ E.from $ \(u,m,p) -> do + E.where_ $ + (m E.^. MetadataName E.==. u E.^. UploadedName) E.&&. + (m E.^. MetadataName E.==. p E.^. PackageName') E.&&. + (p E.^. PackageStackage E.==. E.val sid) + E.orderBy [E.asc $ u E.^. UploadedName] + E.groupBy ( u E.^. UploadedName + , m E.^. MetadataSynopsis + ) + return + ( u E.^. UploadedName + , m E.^. MetadataSynopsis + , E.max_ $ E.case_ + [ ( p E.^. PackageHasHaddocks + , p E.^. PackageVersion + ) + ] + (E.val (Version "")) + ) + let packages = flip map packages' $ \(name, syn, forceNotNull -> mversion) -> + ( E.unValue name + , mversion + , strip $ E.unValue syn + , (<$> mversion) $ \version -> HaddockR slug $ return $ concat + [ toPathPiece $ E.unValue name + , "-" + , version + ] + ) + forceNotNull (E.Value Nothing) = Nothing + forceNotNull (E.Value (Just (Version v))) + | null v = Nothing + | otherwise = Just v + $(widgetFile "package-list") + where strip x = fromMaybe x (stripSuffix "." x) + mback = Just (SnapshotR slug StackageHomeR, "Return to snapshot") diff --git a/config/routes b/config/routes index 79a7ecd..180c88c 100644 --- a/config/routes +++ b/config/routes @@ -22,6 +22,7 @@ /00-index.tar.gz StackageIndexR GET /bundle StackageBundleR GET /package/#PackageNameVersion StackageSdistR GET + /packages SnapshotPackagesR GET /hackage-view/#HackageView/00-index.tar.gz HackageViewIndexR GET /hackage-view/#HackageView/package/#PackageNameVersion HackageViewSdistR GET diff --git a/templates/package-list.hamlet b/templates/package-list.hamlet index 977da28..fd9ed6c 100644 --- a/templates/package-list.hamlet +++ b/templates/package-list.hamlet @@ -1,15 +1,24 @@

Packages + $maybe (back, backText) <- mback +

+ #{asText backText}

- $forall (name,synopsis) <- packages + $forall (name,mversion,synopsis,mdoc) <- packages
Package + Docs Synopsis
#{name} + $maybe version <- mversion + -#{asText version} + + $maybe doc <- mdoc + Docs #{synopsis} diff --git a/templates/stackage-home.hamlet b/templates/stackage-home.hamlet index 2c4bbb7..063c034 100644 --- a/templates/stackage-home.hamlet +++ b/templates/stackage-home.hamlet @@ -17,6 +17,10 @@ $newline never \cabal.config + + + + \Packages $if stackageHasHaddocks stackage