Add deprecation info to stackage (#42)

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

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
+    }

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.

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"

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

config/routes

@@ -50,3 +50,5 @@
 /authors AuthorsR GET
 /install InstallR GET
 /older-releases OlderReleasesR GET
+
+/refresh-deprecated RefreshDeprecatedR GET

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

templates/package.hamlet

@@ -1,7 +1,19 @@
 $newline never
-<div .container #snapshot-home .content>
+<div .container #snapshot-home .content :deprecated:.deprecated>
     <div .row>
         <div .span12>
+            $if deprecated
+              <h1 .package-deprecation-warning>
+                Deprecated
+              $if (not $ null ixInFavourOf)
+                <div .in-favour-of>
+                  In favour of
+                  <div .in-favour-of-list>
+                    $forall (i, pn) <- ixInFavourOf
+                      $if i /= 0
+                        , #
+                      <a href="@{PackageR pn}">
+                        #{pn}
             <h1>
                #{pn} #
                <span .latest-version>

templates/package.lucius

@@ -224,3 +224,26 @@ h2.changes-title {
 div.plain-text {
   white-space: pre-wrap;
 }
+
+
+.deprecated {
+  color: #aaa;
+
+  h1,h2,h3,h4,h5,a {
+    color: #aaa;
+  }
+
+  .package-deprecation-warning{
+    color: red;
+  }
+
+  .in-favour-of {
+    color: #333;
+
+    .in-favour-of-list {
+      a {
+        color: #08c;
+      }
+    }
+  }
+}