fsck distribution key

Annex/Content.hs

@@ -30,6 +30,7 @@ module Annex.Content (
 	freezeContent,
 	thawContent,
 	dirKeys,
+	withObjectLoc,
 ) where
 
 import System.IO.Unsafe (unsafeInterleaveIO)

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"

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