Merge branch 'master' of github.com:fpco/stackage-server

Application.hs

@@ -12,6 +12,7 @@ import           Control.Exception (catch)
 import           Control.Monad.Logger (runLoggingT, LoggingT, defaultLogStr)
 import           Data.BlobStore (fileStore, storeWrite, cachedS3Store)
 import           Data.Hackage
+import           Data.Hackage.DeprecationInfo
 import           Data.Unpacking (newDocUnpacker, createHoogleDatabases)
 import           Data.WebsiteContent
 import           Data.Slug (SnapSlug (..), safeMakeSlug, HasGenIO)
@@ -299,6 +300,17 @@ appLoadCabalFiles updateDB forceUpdate env dbconf p = do
         let runDB' :: SqlPersistT (ResourceT (ReaderT env (LoggingT IO))) a
                    -> ReaderT env (LoggingT IO) a
             runDB' = runResourceT . flip (Database.Persist.runPool dbconf) p
+
+        $logInfo "Updating deprecation tags"
+        loadDeprecationInfo >>= \ei -> case ei of
+            Left e -> $logError (pack e)
+            Right info -> runDB' $ do
+                deleteWhere ([] :: [Filter Deprecated])
+                insertMany_ (deprecations info)
+                deleteWhere ([] :: [Filter Suggested])
+                insertMany_ (suggestions info)
+        $logInfo "Finished updating deprecation tags"
+
         uploadHistory0 <- runDB' $ selectSource [] [] $$ sinkUploadHistory
         let toMDPair (E.Value name, E.Value version, E.Value hash') =
                 (name, (version, hash'))
@@ -320,6 +332,7 @@ appLoadCabalFiles updateDB forceUpdate env dbconf p = do
                 deleteWhere [DependencyUser ==. metadataName md]
                 insertMany_ $ flip map (metadataDeps md) $ \dep ->
                     Dependency (PackageName dep) (metadataName md)
+
     case eres of
         Left e -> $logError $ tshow e
         Right () -> return ()

Data/Hackage/DeprecationInfo.hs

@@ -2,10 +2,11 @@
 -- into model data to be stored in the database.
 module Data.Hackage.DeprecationInfo
   ( HackageDeprecationInfo(..)
+  , loadDeprecationInfo
   ) where
 
-import Prelude
-import Data.Aeson
+import ClassyPrelude.Yesod
+import Data.Aeson as Aeson
 import Model
 import Types
 
@@ -28,13 +29,12 @@ data DeprecationRecord = DeprecationRecord {
 }
 
 instance FromJSON DeprecationRecord where
-  parseJSON j = do
-      obj <- parseJSON j
-      package <- (obj .: "deprecated-package") >>= parsePackageName
-      inFavourOf <- (obj .: "in-favour-of") >>= mapM parsePackageName
+  parseJSON = withObject "DeprecationRecord" $ \obj -> do
+      package <- PackageName <$> (obj .: "deprecated-package")
+      inFavourOf <- map PackageName <$> (obj .: "in-favour-of")
       return $ DeprecationRecord package inFavourOf
     where
-      parsePackageName name = return (PackageName name)
+      parsePackageName = fmap PackageName
 
 toDeprecated :: DeprecationRecord -> Deprecated
 toDeprecated (DeprecationRecord deprecated _) = Deprecated deprecated
@@ -47,3 +47,14 @@ toSuggestions (DeprecationRecord deprecated inFavourOf) =
       suggestedPackage = favoured,
       suggestedInsteadOf = deprecated
     }
+
+loadDeprecationInfo ::
+  ( HasHttpManager env
+  , MonadReader env m
+  , MonadThrow m
+  , MonadIO m)
+  => m (Either String HackageDeprecationInfo)
+loadDeprecationInfo = do
+    req <- parseUrl "http://hackage.haskell.org/packages/deprecated.json"
+    res <- httpLbs req
+    return $! Aeson.eitherDecode (responseBody res)

Handler/Snapshots.hs

@@ -24,19 +24,27 @@ getAllSnapshotsR = do
     currentPageMay <- lookupGetParam "page"
     let currentPage :: Int64
         currentPage = fromMaybe 1 (currentPageMay >>= readMay)
-    groups <- fmap (groupBy (on (==) (\(_,_,uploaded,_,_) -> uploaded)) . map (uncrapify now')) $
-        runDB $ E.select $ E.from $ \(stackage `E.InnerJoin` user) -> do
-          E.on (stackage E.^. StackageUser E.==. user E.^. UserId)
-          E.orderBy [E.desc $ stackage E.^. StackageUploaded]
-          E.limit snapshotsPerPage
-          E.offset ((currentPage - 1) * snapshotsPerPage)
-          return
-              ( stackage E.^. StackageSlug
-              , stackage E.^. StackageTitle
-              , stackage E.^. StackageUploaded
-              , user E.^. UserDisplay
-              , user E.^. UserHandle
-              )
+    (totalCount :: Int64, groups) <- fmap (groupUp now') $ runDB $ do
+        c <- E.select $ E.from $ \(stackage `E.InnerJoin` user) -> do
+            E.on (stackage E.^. StackageUser E.==. user E.^. UserId)
+            return E.countRows
+        rs <- E.select $ E.from $ \(stackage `E.InnerJoin` user) -> do
+            E.on (stackage E.^. StackageUser E.==. user E.^. UserId)
+            E.orderBy [E.desc $ stackage E.^. StackageUploaded]
+            E.limit snapshotsPerPage
+            E.offset ((currentPage - 1) * snapshotsPerPage)
+            return
+                ( stackage E.^. StackageSlug
+                , stackage E.^. StackageTitle
+                , stackage E.^. StackageUploaded
+                , user E.^. UserDisplay
+                , user E.^. UserHandle
+                )
+        return (c, rs)
+
+    let isFirstPage = currentPage == 1
+        isLastPage = currentPage * snapshotsPerPage >= totalCount
+
     defaultLayout $ do
         setTitle "Stackage Server"
         let snapshotsNav = $(widgetFile "snapshots-nav")
@@ -44,3 +52,5 @@ getAllSnapshotsR = do
   where uncrapify now' c =
             let (E.Value ident, E.Value title, E.Value uploaded, E.Value display, E.Value handle') = c
             in (ident,title,format (diff True) (diffUTCTime uploaded now'),display,handle')
+        groupUp now' ([E.Value c], rs) = (c, (groupBy (on (==) (\(_,_,uploaded,_,_) -> uploaded)) . map (uncrapify now')) rs)
+        groupUp _ _ = error "Expected countRows to have exactly 1 result."

templates/snapshots-nav.hamlet

@@ -1,12 +1,12 @@
 <div .snapshot-nav>
-  $if currentPage > 1
+  $if isFirstPage
+    at newest --
+  $else
     <a href=@{AllSnapshotsR}?page=#{currentPage - 1}>
       see newer --
-  $else
-    at newest --
   \ Page #{currentPage} #
-  $if length (concat groups) == snapshotsPerPage
+  $if isLastPage
+    ++ at oldest
+  $else
     <a href=@{AllSnapshotsR}?page=#{currentPage + 1}>
       ++ see older
-  $else
-    ++ at oldest