From b06424463ec4d2e15c4503ff1684bb2b9ea569d0 Mon Sep 17 00:00:00 2001 From: Dan Burton Date: Sun, 21 Dec 2014 13:48:15 -0800 Subject: [PATCH] Add deprecation info to stackage (#42) --- Application.hs | 1 + Data/Hackage/DeprecationInfo.hs | 49 +++++++++++++++++++++++++++++++++ Handler/Package.hs | 20 +++++++++++++- Handler/RefreshDeprecated.hs | 20 ++++++++++++++ config/models | 9 ++++++ config/routes | 2 ++ stackage-server.cabal | 2 ++ templates/package.hamlet | 14 +++++++++- templates/package.lucius | 23 ++++++++++++++++ 9 files changed, 138 insertions(+), 2 deletions(-) create mode 100644 Data/Hackage/DeprecationInfo.hs create mode 100644 Handler/RefreshDeprecated.hs diff --git a/Application.hs b/Application.hs index fc9ebd8..5482d97 100644 --- a/Application.hs +++ b/Application.hs @@ -67,6 +67,7 @@ import Handler.PackageList import Handler.CompressorStatus import Handler.Tag import Handler.BannedTags +import Handler.RefreshDeprecated -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the diff --git a/Data/Hackage/DeprecationInfo.hs b/Data/Hackage/DeprecationInfo.hs new file mode 100644 index 0000000..9bdbd90 --- /dev/null +++ b/Data/Hackage/DeprecationInfo.hs @@ -0,0 +1,49 @@ +-- | Transforms http://hackage.haskell.org/packages/deprecated.json +-- into model data to be stored in the database. +module Data.Hackage.DeprecationInfo + ( HackageDeprecationInfo(..) + ) where + +import Prelude +import Data.Aeson +import Model +import Types + +data HackageDeprecationInfo = HackageDeprecationInfo { + deprecations :: [Deprecated], + suggestions :: [Suggested] +} + +instance FromJSON HackageDeprecationInfo where + parseJSON j = do + deprecationRecords <- parseJSON j + return $ HackageDeprecationInfo { + deprecations = map toDeprecated deprecationRecords, + suggestions = concatMap toSuggestions deprecationRecords + } + +data DeprecationRecord = DeprecationRecord { + deprecatedPackage :: PackageName, + deprecatedInFavourOf :: [PackageName] +} + +instance FromJSON DeprecationRecord where + parseJSON j = do + obj <- parseJSON j + package <- (obj .: "deprecated-package") >>= parsePackageName + inFavourOf <- (obj .: "in-favour-of") >>= mapM parsePackageName + return $ DeprecationRecord package inFavourOf + where + parsePackageName name = return (PackageName name) + +toDeprecated :: DeprecationRecord -> Deprecated +toDeprecated (DeprecationRecord deprecated _) = Deprecated deprecated + +toSuggestions :: DeprecationRecord -> [Suggested] +toSuggestions (DeprecationRecord deprecated inFavourOf) = + map toSuggestion inFavourOf + where + toSuggestion favoured = Suggested { + suggestedPackage = favoured, + suggestedInsteadOf = deprecated + } diff --git a/Handler/Package.hs b/Handler/Package.hs index 2f8bb48..b2a843c 100644 --- a/Handler/Package.hs +++ b/Handler/Package.hs @@ -26,7 +26,7 @@ getPackageR pn = do HaddockR ident [concat [toPathPiece pn, "-", toPathPiece version]] muid <- maybeAuthId (mnightly, mlts, nLikes, liked, - Entity _ metadata, revdeps', mdocs) <- runDB $ do + Entity _ metadata, revdeps', mdocs, deprecated, inFavourOf) <- runDB $ do mnightly <- getNightly pn mlts <- getLts pn nLikes <- count [LikePackage ==. pn] @@ -42,6 +42,8 @@ getPackageR pn = do <$> pure version <*> (map entityVal <$> selectList [ModuleDocs ==. docsid] [Asc ModuleName]) + deprecated <- getDeprecated pn + inFavourOf <- getInFavourOf pn return ( mnightly , mlts , nLikes @@ -49,8 +51,12 @@ getPackageR pn = do , metadata , revdeps' , mdocs + , deprecated + , inFavourOf ) + let ixInFavourOf = zip [0::Int ..] inFavourOf + myTags <- maybe (return []) (runDB . user'sTagsOf pn) muid tags <- fmap (map (\(v,count') -> (v,count',any (==v) myTags))) (runDB (packageTags pn)) @@ -146,6 +152,18 @@ getLts pn = ,p ^. PackageVersion ,s ^. StackageSlug) +getDeprecated :: PackageName -> YesodDB App Bool +getDeprecated pn = fmap ((>0) . length) $ E.select $ E.from $ \d -> do + E.where_ $ d ^. DeprecatedPackage E.==. E.val pn + return () + +getInFavourOf :: PackageName -> YesodDB App [PackageName] +getInFavourOf pn = fmap unBoilerplate $ E.select $ E.from $ \s -> do + E.where_ $ s ^. SuggestedInsteadOf E.==. E.val pn + return (s ^. SuggestedPackage) + where + unBoilerplate = map (\(E.Value p) -> p) + -- | An identifier specified in a package. Because this field has -- quite liberal requirements, we often encounter various forms. A -- name, a name and email, just an email, or maybe nothing at all. diff --git a/Handler/RefreshDeprecated.hs b/Handler/RefreshDeprecated.hs new file mode 100644 index 0000000..73906c1 --- /dev/null +++ b/Handler/RefreshDeprecated.hs @@ -0,0 +1,20 @@ +module Handler.RefreshDeprecated where + +import Import +import qualified Data.Aeson as Aeson +import Network.HTTP.Conduit (simpleHttp) +import Data.Hackage.DeprecationInfo + +getRefreshDeprecatedR :: Handler Html +getRefreshDeprecatedR = do + bs <- simpleHttp "http://hackage.haskell.org/packages/deprecated.json" + case Aeson.decode bs of + Nothing -> return "Failed to parse" + Just info -> do + runDB $ do + deleteWhere ([] :: [Filter Deprecated]) + insertMany_ (deprecations info) + runDB $ do + deleteWhere ([] :: [Filter Suggested]) + insertMany_ (suggestions info) + return "Done" diff --git a/config/models b/config/models index b8385d5..0b3d3d8 100644 --- a/config/models +++ b/config/models @@ -122,3 +122,12 @@ Lts minor Int stackage StackageId UniqueLts major minor + +Deprecated + package PackageName + UniqueDeprecated package + +Suggested + package PackageName + insteadOf PackageName + UniqueSuggested package insteadOf diff --git a/config/routes b/config/routes index 4fdb0d3..d8e4931 100644 --- a/config/routes +++ b/config/routes @@ -50,3 +50,5 @@ /authors AuthorsR GET /install InstallR GET /older-releases OlderReleasesR GET + +/refresh-deprecated RefreshDeprecatedR GET diff --git a/stackage-server.cabal b/stackage-server.cabal index 71da4ee..a4a0b0d 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -25,6 +25,7 @@ library Data.Tag Data.BlobStore Data.Hackage + Data.Hackage.DeprecationInfo Data.Hackage.Views Data.WebsiteContent Types @@ -49,6 +50,7 @@ library Handler.CompressorStatus Handler.Tag Handler.BannedTags + Handler.RefreshDeprecated if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT diff --git a/templates/package.hamlet b/templates/package.hamlet index 5e4c70b..322bf89 100644 --- a/templates/package.hamlet +++ b/templates/package.hamlet @@ -1,7 +1,19 @@ $newline never -
+
+ $if deprecated +

+ Deprecated + $if (not $ null ixInFavourOf) +