Fix warnings in Handler.Package

Handler/Package.hs

@@ -19,7 +19,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import qualified Data.Text.Lazy as LT
 
-import           Database.Esqueleto ((^.), (&&.), Value (Value))
+import           Database.Esqueleto ((^.))
 import qualified Database.Esqueleto as E
 import qualified Database.Persist as P
 import           Formatting
@@ -39,7 +39,6 @@ packagePage mversion pname = do
     let pname' = toPathPiece pname
     (deprecated, inFavourOf) <- getDeprecated pname'
     latests <- getLatests pname'
-    render <- getUrlRender
     muid <- maybeAuthId
     (nLikes, liked) <- runDB $ do
         nLikes <- count [LikePackage ==. pname]
@@ -212,10 +211,6 @@ parseChunk chunk =
 renderEmail :: EmailAddress -> Text
 renderEmail = T.decodeUtf8 . toByteString
 
--- | Format a number with commas nicely.
-formatNum :: Int -> Text
-formatNum = sformat commas
-
 postPackageLikeR :: PackageName -> Handler ()
 postPackageLikeR packageName = maybeAuthId >>= \muid -> case muid of
     Nothing -> return ()
@@ -258,31 +253,10 @@ postPackageUntagR packageName =
              Nothing -> error "Need a slug"
 
 getPackageSnapshotsR :: PackageName -> Handler Html
-getPackageSnapshotsR pn = error "getPackageSnapshotsR"
+getPackageSnapshotsR pn =
-{-
+  do snapshots <- getSnapshotsForPackage $ toPathPiece pn
-  do let haddocksLink ident version =
-             HaddockR ident [concat [toPathPiece pn, "-", toPathPiece version]]
-     snapshots <- (runDB .
-                   fmap (map reformat) .
-                   E.select . E.from)
-                    (\(p,s) ->
-                       do E.where_ $
-                            (p ^. PackageStackage E.==. s ^. StackageId) &&.
-                            (p ^. PackageName' E.==. E.val pn)
-                          E.orderBy [E.desc $ s ^. StackageUploaded]
-                          return
-                            (p ^. PackageVersion
-                            ,s ^. StackageTitle
-                            ,s ^. StackageSlug
-                            ,s ^. StackageHasHaddocks))
      defaultLayout
        (do setTitle ("Packages for " >> toHtml pn)
            $(combineStylesheets 'StaticR
                                 [css_font_awesome_min_css])
            $(widgetFile "package-snapshots"))
-  where reformat (Value version,Value title,Value ident,Value hasHaddocks) =
-          (version
-          ,fromMaybe title (stripPrefix "Stackage build for " title)
-          ,ident
-          ,hasHaddocks)
-          -}

Stackage/Database.hs

@@ -26,6 +26,7 @@ module Stackage.Database
     , Package (..)
     , getPackage
     , prettyName
+    , getSnapshotsForPackage
     ) where
 
 import Database.Sqlite (SqliteException)
@@ -573,3 +574,17 @@ getRevDeps pname = run $ do
 
 getPackage :: GetStackageDatabase m => Text -> m (Maybe (Entity Package))
 getPackage = run . getBy . UniquePackage
+
+getSnapshotsForPackage
+    :: GetStackageDatabase m
+    => Text
+    -> m [(Snapshot, Text)] -- version
+getSnapshotsForPackage pname = run $ do
+    pid <- getPackageId pname
+    sps <- selectList [SnapshotPackagePackage ==. pid] []
+    fmap catMaybes $ forM sps $ \(Entity _ sp) -> do
+        let sid = snapshotPackageSnapshot sp
+        ms <- get sid
+        return $ case ms of
+            Nothing -> Nothing
+            Just s -> Just (s, snapshotPackageVersion sp)

templates/package-snapshots.hamlet

@@ -10,13 +10,9 @@ $newline never
                         Package
                     <th>
                         Snapshot
-                $forall (version, title, slug, hasHaddocks) <- snapshots
+                $forall (snapshot, version) <- snapshots
                     <tr>
-                        <td>
-                            $if hasHaddocks
-                              <a href=@{haddocksLink slug version}>
-                                  Docs
                         <td>
                             #{version}
                         <td>
-                            <a href=@{SnapshotR slug StackageHomeR}>#{fromMaybe title $ stripSuffix ", exclusive" title}
+                            <a href=@{SnapshotR (snapshotName snapshot) $ StackageSdistR $ PNVName pn}>#{snapshotTitle snapshot}