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

@@ -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

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]
                             )

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

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")

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

templates/package-list.hamlet

@@ -1,15 +1,24 @@
 <div .container>
     <h1>Packages
+    $maybe (back, backText) <- mback
+        <p>
+            <a href=@{back}>#{asText backText}
     <div .packages>
         <table .table>
             <thead>
                 <th>Package
+                <th>Docs
                 <th>Synopsis
             <tbody>
-                $forall (name,synopsis) <- packages
+                $forall (name,mversion,synopsis,mdoc) <- packages
                     <tr>
                         <td>
                             <a href=@{PackageR name}>
                                 #{name}
+                                $maybe version <- mversion
+                                    -#{asText version}
+                        <td>
+                            $maybe doc <- mdoc
+                                <a href=@{doc}>Docs
                         <td>
                             #{synopsis}

templates/stackage-home.hamlet

@@ -17,6 +17,10 @@ $newline never
            <span>
                <a href=@{SnapshotR slug StackageCabalConfigR} title="If you want to stick with upstream Hackage but get a stable package set">
                    \cabal.config
+           <span .separator>
+           <span>
+               <a href=@{SnapshotR slug SnapshotPackagesR} title="List of included packages">
+                   \Packages
            $if stackageHasHaddocks stackage
                <span .separator>
                <span>