From 07fb2c92908a6358b73537188472233bed0a0091 Mon Sep 17 00:00:00 2001 From: Dan Burton Date: Tue, 17 Mar 2015 11:20:09 -0700 Subject: [PATCH 1/2] Snapshot list pagination now correctly uses row count to determine whether the last page has been reached. --- Handler/Snapshots.hs | 36 ++++++++++++++++++++++------------ templates/snapshots-nav.hamlet | 12 ++++++------ 2 files changed, 29 insertions(+), 19 deletions(-) diff --git a/Handler/Snapshots.hs b/Handler/Snapshots.hs index bb9139e..88b9802 100644 --- a/Handler/Snapshots.hs +++ b/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." diff --git a/templates/snapshots-nav.hamlet b/templates/snapshots-nav.hamlet index 331080e..c887e16 100644 --- a/templates/snapshots-nav.hamlet +++ b/templates/snapshots-nav.hamlet @@ -1,12 +1,12 @@
- $if currentPage > 1 + $if isFirstPage + at newest -- + $else see newer -- - $else - at newest -- \ Page #{currentPage} # - $if length (concat groups) == snapshotsPerPage + $if isLastPage + ++ at oldest + $else ++ see older - $else - ++ at oldest From ed23d5edc79cd787cf3303fe670ff555d1d65c82 Mon Sep 17 00:00:00 2001 From: Dan Burton Date: Tue, 17 Mar 2015 12:42:50 -0700 Subject: [PATCH 2/2] Hooked DeprecationInfo update procedure into appLoadCabalFiles --- Application.hs | 13 +++++++++++++ Data/Hackage/DeprecationInfo.hs | 25 ++++++++++++++++++------- 2 files changed, 31 insertions(+), 7 deletions(-) diff --git a/Application.hs b/Application.hs index 802bfa9..81cec14 100644 --- a/Application.hs +++ b/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 () diff --git a/Data/Hackage/DeprecationInfo.hs b/Data/Hackage/DeprecationInfo.hs index 238a4f5..e59844e 100644 --- a/Data/Hackage/DeprecationInfo.hs +++ b/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)