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