From e563c7e6f425dfa931bb961b01fd8d89c2970379 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sat, 23 Nov 2013 21:58:39 -0400
Subject: [PATCH] fsck distribution key

---
 Annex/Content.hs                          |  1 +
 Assistant/Upgrade.hs                      | 33 ++++++++++++++++++++++-
 Assistant/WebApp/Configurators/Upgrade.hs |  7 +----
 3 files changed, 34 insertions(+), 7 deletions(-)

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 13a43b16e1..62f1b1ccbe 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -30,6 +30,7 @@ module Annex.Content (
 	freezeContent,
 	thawContent,
 	dirKeys,
+	withObjectLoc,
 ) where
 
 import System.IO.Unsafe (unsafeInterleaveIO)
diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs
index acfbeef6bf..a5d80569c4 100644
--- a/Assistant/Upgrade.hs
+++ b/Assistant/Upgrade.hs
@@ -12,9 +12,14 @@ import Assistant.Restart
 import qualified Annex
 import Assistant.Alert
 import Assistant.DaemonStatus
-import Utility.Url
 import Utility.Env
 import Types.Distribution
+import Logs.Transfer
+import Logs.Web
+import Annex.Content
+import qualified Backend
+import qualified Types.Backend
+import qualified Types.Key
 
 {- Upgrade without interaction in the webapp. -}
 unattendedUpgrade :: Assistant ()
@@ -40,3 +45,29 @@ checkSuccessfulUpgrade = isJust <$> getEnv upgradedEnv
 
 upgradedEnv :: String
 upgradedEnv = "GIT_ANNEX_UPGRADED"
+
+{- Fsck the key to verify the download. -}
+distributionDownloadComplete :: GitAnnexDistribution -> Transfer -> Assistant ()
+distributionDownloadComplete d t 
+	| transferDirection t == Download = do
+		maybe noop upgradeToDistribution
+			=<< liftAnnex (withObjectLoc k fsckit (getM fsckit))
+		liftAnnex $ setUrlMissing k (distributionUrl d)
+	| otherwise = noop
+  where
+	k = distributionKey d
+	fsckit f = case Backend.maybeLookupBackendName (Types.Key.keyBackendName k) of
+		Nothing -> return $ Just f
+		Just b -> case Types.Backend.fsckKey b of
+			Nothing -> return $ Just f
+			Just a -> ifM (a k f)
+				( return $ Just f
+				, do
+					-- unlikely to resume a bad
+					-- download from web
+					liftIO $ nukeFile f
+					return Nothing
+				)
+
+upgradeToDistribution :: FilePath -> Assistant ()
+upgradeToDistribution f = error "TODO"
diff --git a/Assistant/WebApp/Configurators/Upgrade.hs b/Assistant/WebApp/Configurators/Upgrade.hs
index e81eb2475a..53798565ed 100644
--- a/Assistant/WebApp/Configurators/Upgrade.hs
+++ b/Assistant/WebApp/Configurators/Upgrade.hs
@@ -38,7 +38,7 @@ getConfigStartUpgradeR d = do
 		let k = distributionKey d
 		let u = distributionUrl d
 		liftAnnex $ setUrlPresent k u
-		hook <- asIO1 $ downloadComplete d
+		hook <- asIO1 $ distributionDownloadComplete d
 		modifyDaemonStatus_ $ \status -> status
 			{ transferHook = M.insert k hook (transferHook status) }
 		let t = Transfer
@@ -53,11 +53,6 @@ getConfigStartUpgradeR d = do
 	redirect DashboardR
 #endif
 
-downloadComplete :: GitAnnexDistribution -> Transfer -> Assistant ()
-downloadComplete d t = do
-	error "TODO"
-	liftAnnex $ setUrlMissing (distributionKey d) (distributionUrl d)
-
 {- Finish upgrade by starting the new assistant in the same repository this
  - one is running in, and redirecting to it. -}
 getConfigFinishUpgradeR :: Handler Html