From 3a8bdb2ade937fc5d3d6ebf2e0385fa69776f13c Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Mon, 24 Nov 2014 11:35:01 +0200
Subject: [PATCH] STACKAGE_FORCE_UPDATE

---
 Application.hs  | 13 +++++++++----
 Data/Hackage.hs | 11 +++++++----
 2 files changed, 16 insertions(+), 8 deletions(-)

diff --git a/Application.hs b/Application.hs
index a475ae6..8dded46 100644
--- a/Application.hs
+++ b/Application.hs
@@ -186,7 +186,8 @@ makeFoundation useEcho conf = do
 
     env <- getEnvironment
     let updateDB = lookup "STACKAGE_CABAL_LOADER" env /= Just "0"
-        loadCabalFiles' = appLoadCabalFiles updateDB foundation dbconf p
+        forceUpdate = lookup "STACKAGE_FORCE_UPDATE" env == Just "1"
+        loadCabalFiles' = appLoadCabalFiles updateDB forceUpdate foundation dbconf p
 
     -- Start the cabal file loader
     ifRunCabalLoader $ forkIO $ forever $ flip runLoggingT (messageLoggerSource foundation logger) $ do
@@ -225,8 +226,11 @@ cabalLoaderMain = do
     manager <- newManager
     bs <- loadBlobStore manager conf
     hSetBuffering stdout LineBuffering
+    env <- getEnvironment
+    let forceUpdate = lookup "STACKAGE_FORCE_UPDATE" env == Just "1"
     flip runLoggingT logFunc $ appLoadCabalFiles
-        True
+        True -- update database?
+        forceUpdate
         CabalLoaderEnv
             { cleSettings = conf
             , cleBlobStore = bs
@@ -246,11 +250,12 @@ appLoadCabalFiles :: ( PersistConfig c
                      , HasHttpManager env
                      )
                   => Bool -- ^ update database?
+                  -> Bool -- ^ force update?
                   -> env
                   -> c
                   -> PersistConfigPool c
                   -> LoggingT IO ()
-appLoadCabalFiles updateDB env dbconf p = do
+appLoadCabalFiles updateDB forceUpdate env dbconf p = do
     eres <- tryAny $ flip runReaderT env $ do
         let runDB' :: SqlPersistT (ResourceT (ReaderT env (LoggingT IO))) a
                    -> ReaderT env (LoggingT IO) a
@@ -264,7 +269,7 @@ appLoadCabalFiles updateDB env dbconf p = do
             , m E.^. MetadataVersion
             , m E.^. MetadataHash
             )
-        UploadState uploadHistory newUploads _ newMD <- loadCabalFiles updateDB uploadHistory0 metadata0
+        UploadState uploadHistory newUploads _ newMD <- loadCabalFiles updateDB forceUpdate uploadHistory0 metadata0
         $logInfo "Inserting to new uploads"
         runDB' $ insertMany_ newUploads
         $logInfo "Updating metadatas"
diff --git a/Data/Hackage.hs b/Data/Hackage.hs
index c886224..a72f0cc 100644
--- a/Data/Hackage.hs
+++ b/Data/Hackage.hs
@@ -62,10 +62,11 @@ loadCabalFiles :: ( MonadActive m
                   , MonadMask m
                   )
                => Bool -- ^ do the database updating
+               -> Bool -- ^ force updates regardless of hash value?
                -> UploadHistory -- ^ initial
                -> HashMap PackageName (Version, ByteString)
                -> m (UploadState Metadata)
-loadCabalFiles dbUpdates uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT (UploadState uploadHistory0 [] metadata1 mempty) $ do
+loadCabalFiles dbUpdates forceUpdate uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT (UploadState uploadHistory0 [] metadata1 mempty) $ do
     HackageRoot root <- liftM getHackageRoot ask
     $logDebug $ "Entering loadCabalFiles, root == " ++ root
     req <- parseUrl $ unpack $ root ++ "/00-index.tar.gz"
@@ -116,6 +117,7 @@ loadCabalFiles dbUpdates uploadHistory0 metadata0 = (>>= runUploadState) $ flip
                         case readVersion version of
                             Nothing -> return ()
                             Just dataVersion -> setMetadata
+                                forceUpdate
                                 name
                                 version
                                 dataVersion
@@ -199,13 +201,14 @@ setMetadata :: ( MonadBaseControl IO m
                , HasBlobStore env StoreKey
                , HasHackageRoot env
                )
-            => PackageName
+            => Bool -- ^ force update?
+            -> PackageName
             -> Version
             -> UVector Int -- ^ versionBranch
             -> ByteString
             -> ParseResult PD.GenericPackageDescription
             -> m ()
-setMetadata name version dataVersion hash' gpdRes = do
+setMetadata forceUpdate name version dataVersion hash' gpdRes = do
     UploadState us1 us2 mdMap mdChanges <- get
     let toUpdate =
             case lookup name mdMap of
@@ -213,7 +216,7 @@ setMetadata name version dataVersion hash' gpdRes = do
                     case compare currDataVersion dataVersion of
                         LT -> True
                         GT -> False
-                        EQ -> currHash /= hash'
+                        EQ -> currHash /= hash' || forceUpdate
                 Nothing -> True
     if toUpdate
         then case gpdRes of