From ed23d5edc79cd787cf3303fe670ff555d1d65c82 Mon Sep 17 00:00:00 2001
From: Dan Burton <danburton.email@gmail.com>
Date: Tue, 17 Mar 2015 12:42:50 -0700
Subject: [PATCH] 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)