run Preparer to get Remover and CheckPresent actions

This will allow special remotes to eg, open a http connection and reuse it,
while checking if chunks are present, or removing chunks.

S3 and WebDAV both need this to support chunks with reasonable speed.

Note that a special remote might want to cache a http connection across
multiple requests. A simple case of this is that CheckPresent is typically
called before Store or Remove. A remote using this interface can certianly
use a Preparer that eg, uses a MVar to cache a http connection.

However, it's up to the remote to then deal with things like stale or
stalled http connections when eg, doing a series of downloads from a remote
and other places. There could be long delays between calls to a remote,
which could lead to eg, http connection stalls; the machine might even
move to a new network, etc.

It might be nice to improve this interface later to allow
the simple case without needing to handle the full complex case.
One way to do it would be to have a `Transaction SpecialRemote cache`,
where SpecialRemote contains methods for Storer, Retriever, Remover, and
CheckPresent, that all expect to be passed a `cache`.

Remote/Bup.hs

@@ -57,8 +57,8 @@ gen r u c gc = do
 		, storeKey = storeKeyDummy
 		, retrieveKeyFile = retreiveKeyFileDummy
 		, retrieveKeyFileCheap = retrieveCheap buprepo
-		, removeKey = remove buprepo
+		, removeKey = removeKeyDummy
-		, checkPresent = checkKey r bupr'
+		, checkPresent = checkPresentDummy
 		, checkPresentCheap = bupLocal buprepo
 		, whereisKey = Nothing
 		, remoteFsck = Nothing
@@ -76,6 +76,8 @@ gen r u c gc = do
 	return $ Just $ specialRemote' specialcfg c
 		(simplyPrepare $ store this buprepo)
 		(simplyPrepare $ retrieve buprepo)
+		(simplyPrepare $ remove buprepo)
+		(simplyPrepare $ checkKey r bupr')
 		this
   where
 	buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc
@@ -146,7 +148,7 @@ retrieveCheap _ _ _ = return False
  -
  - We can, however, remove the git branch that bup created for the key.
  -}
-remove :: BupRepo -> Key -> Annex Bool
+remove :: BupRepo -> Remover
 remove buprepo k = do
 	go =<< liftIO (bup2GitRemote buprepo)
 	warning "content cannot be completely removed from bup remote"
@@ -163,7 +165,7 @@ remove buprepo k = do
  - in a bup repository. One way it to check if the git repository has
  - a branch matching the name (as created by bup split -n).
  -}
-checkKey :: Git.Repo -> Git.Repo -> Key -> Annex Bool
+checkKey :: Git.Repo -> Git.Repo -> CheckPresent
 checkKey r bupr k
 	| Git.repoIsUrl bupr = do
 		showChecking r

Remote/Ddar.hs

@@ -44,6 +44,8 @@ gen r u c gc = do
 	return $ Just $ specialRemote' specialcfg c
 		(simplyPrepare $ store ddarrepo)
 		(simplyPrepare $ retrieve ddarrepo)
+		(simplyPrepare $ remove ddarrepo)
+		(simplyPrepare $ checkKey ddarrepo)
 		(this cst)
   where
 	this cst = Remote
@@ -53,8 +55,8 @@ gen r u c gc = do
 		, storeKey = storeKeyDummy
 		, retrieveKeyFile = retreiveKeyFileDummy
 		, retrieveKeyFileCheap = retrieveCheap
-		, removeKey = remove ddarrepo
+		, removeKey = removeKeyDummy
-		, checkPresent = checkKey ddarrepo
+		, checkPresent = checkPresentDummy
 		, checkPresentCheap = ddarLocal ddarrepo
 		, whereisKey = Nothing
 		, remoteFsck = Nothing
@@ -140,7 +142,7 @@ retrieve ddarrepo = byteRetriever $ \k sink -> do
 retrieveCheap :: Key -> FilePath -> Annex Bool
 retrieveCheap _ _ = return False
 
-remove :: DdarRepo -> Key -> Annex Bool
+remove :: DdarRepo -> Remover
 remove ddarrepo key = do
 	(cmd, params) <- ddarRemoteCall ddarrepo 'd' [Param $ key2file key]
 	liftIO $ boolSystem cmd params
@@ -181,7 +183,7 @@ inDdarManifest ddarrepo k = do
   where
 	k' = key2file k
 
-checkKey :: DdarRepo -> Key -> Annex Bool
+checkKey :: DdarRepo -> CheckPresent
 checkKey ddarrepo key = do
 	directoryExists <- ddarDirectoryExists ddarrepo
 	case directoryExists of

Remote/Directory.hs

@@ -44,6 +44,8 @@ gen r u c gc = do
 	return $ Just $ specialRemote c
 		(prepareStore dir chunkconfig)
 		(retrieve dir chunkconfig)
+		(simplyPrepare $ remove dir)
+		(simplyPrepare $ checkKey dir chunkconfig)
 		Remote {
 			uuid = u,
 			cost = cst,
@@ -51,8 +53,8 @@ gen r u c gc = do
 			storeKey = storeKeyDummy,
 			retrieveKeyFile = retreiveKeyFileDummy,
 			retrieveKeyFileCheap = retrieveCheap dir chunkconfig,
-			removeKey = remove dir,
+			removeKey = removeKeyDummy,
-			checkPresent = checkKey dir chunkconfig,
+			checkPresent = checkPresentDummy,
 			checkPresentCheap = True,
 			whereisKey = Nothing,
 			remoteFsck = Nothing,
@@ -161,7 +163,7 @@ retrieveCheap d NoChunks k f = liftIO $ catchBoolIO $ do
 retrieveCheap _ _ _ _ = return False
 #endif
 
-remove :: FilePath -> Key -> Annex Bool
+remove :: FilePath -> Remover
 remove d k = liftIO $ removeDirGeneric d (storeDir d k)
 
 {- Removes the directory, which must be located under the topdir.
@@ -189,7 +191,7 @@ removeDirGeneric topdir dir = do
 		then return ok
 		else doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)
 
-checkKey :: FilePath -> ChunkConfig -> Key -> Annex Bool
+checkKey :: FilePath -> ChunkConfig -> CheckPresent
 checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k
 checkKey d _ k = liftIO $
 	ifM (anyM doesFileExist (locations d k))

Remote/External.hs

@@ -45,6 +45,8 @@ gen r u c gc = do
 	return $ Just $ specialRemote c
 		(simplyPrepare $ store external)
 		(simplyPrepare $ retrieve external)
+		(simplyPrepare $ remove external)
+		(simplyPrepare $ checkKey external)
 		Remote {
 			uuid = u,
 			cost = cst,
@@ -52,8 +54,8 @@ gen r u c gc = do
 			storeKey = storeKeyDummy,
 			retrieveKeyFile = retreiveKeyFileDummy,
 			retrieveKeyFileCheap = \_ _ -> return False,
-			removeKey = remove external,
+			removeKey = removeKeyDummy,
-			checkPresent = checkKey external,
+			checkPresent = checkPresentDummy,
 			checkPresentCheap = False,
 			whereisKey = Nothing,
 			remoteFsck = Nothing,
@@ -109,7 +111,7 @@ retrieve external = fileRetriever $ \d k p ->
 					error errmsg
 			_ -> Nothing
 
-remove :: External -> Key -> Annex Bool
+remove :: External -> Remover
 remove external k = safely $ 
 	handleRequest external (REMOVE k) Nothing $ \resp ->
 		case resp of
@@ -121,7 +123,7 @@ remove external k = safely $
 					return False
 			_ -> Nothing
 
-checkKey :: External -> Key -> Annex Bool
+checkKey :: External -> CheckPresent
 checkKey external k = either error id <$> go
   where
 	go = handleRequest external (CHECKPRESENT k) Nothing $ \resp ->

Remote/GCrypt.hs

@@ -107,8 +107,8 @@ gen' r u c gc = do
 		, storeKey = storeKeyDummy
 		, retrieveKeyFile = retreiveKeyFileDummy
 		, retrieveKeyFileCheap = \_ _ -> return False
-		, removeKey = remove this rsyncopts
+		, removeKey = removeKeyDummy
-		, checkPresent = checkKey this rsyncopts
+		, checkPresent = checkPresentDummy
 		, checkPresentCheap = repoCheap r
 		, whereisKey = Nothing
 		, remoteFsck = Nothing
@@ -124,6 +124,8 @@ gen' r u c gc = do
 	return $ Just $ specialRemote' specialcfg c
 		(simplyPrepare $ store this rsyncopts)
 		(simplyPrepare $ retrieve this rsyncopts)
+		(simplyPrepare $ remove this rsyncopts)
+		(simplyPrepare $ checkKey this rsyncopts)
 		this
   where
 	specialcfg
@@ -331,7 +333,7 @@ retrieve r rsyncopts
 	| otherwise = unsupportedUrl
   where
 
-remove :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex Bool
+remove :: Remote -> Remote.Rsync.RsyncOpts -> Remover
 remove r rsyncopts k
 	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $
 		liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation (repo r)) (parentDir (gCryptLocation r k))
@@ -341,7 +343,7 @@ remove r rsyncopts k
 	removersync = Remote.Rsync.remove rsyncopts k
 	removeshell = Ssh.dropKey (repo r) k
 
-checkKey :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex Bool
+checkKey :: Remote -> Remote.Rsync.RsyncOpts -> CheckPresent
 checkKey r rsyncopts k
 	| not $ Git.repoIsUrl (repo r) =
 		guardUsable (repo r) (cantCheck $ repo r) $

Remote/Glacier.hs

@@ -42,6 +42,8 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
 	new cst = Just $ specialRemote' specialcfg c
 		(prepareStore this)
 		(prepareRetrieve this)
+		(simplyPrepare $ remove this)
+		(simplyPrepare $ checkKey this)
 		this
 	  where
 		this = Remote {
@@ -51,8 +53,8 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
 			storeKey = storeKeyDummy,
 			retrieveKeyFile = retreiveKeyFileDummy,
 			retrieveKeyFileCheap = retrieveCheap this,
-			removeKey = remove this,
+			removeKey = removeKeyDummy,
-			checkPresent = checkKey this,
+			checkPresent = checkPresentDummy,
 			checkPresentCheap = False,
 			whereisKey = Nothing,
 			remoteFsck = Nothing,
@@ -155,7 +157,7 @@ retrieve r k sink = go =<< glacierEnv c u
 retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
 retrieveCheap _ _ _ = return False
 
-remove :: Remote -> Key -> Annex Bool
+remove :: Remote -> Remover
 remove r k = glacierAction r
 	[ Param "archive"
 	
@@ -164,7 +166,7 @@ remove r k = glacierAction r
 	, Param $ archive r k
 	]
 
-checkKey :: Remote -> Key -> Annex Bool
+checkKey :: Remote -> CheckPresent
 checkKey r k = do
 	showAction $ "checking " ++ name r
 	go =<< glacierEnv (config r) (uuid r)

Remote/Helper/Messages.hs

@@ -9,9 +9,19 @@ module Remote.Helper.Messages where
 
 import Common.Annex
 import qualified Git
+import qualified Types.Remote as Remote
 
 showChecking :: Git.Repo -> Annex ()
 showChecking r = showAction $ "checking " ++ Git.repoDescribe r
 
-cantCheck :: Git.Repo -> a
+class Checkable a where
-cantCheck r = error $ "unable to check " ++ Git.repoDescribe r
+	descCheckable :: a -> String
+
+instance Checkable Git.Repo where
+	descCheckable = Git.repoDescribe
+
+instance Checkable (Remote.RemoteA a) where
+	descCheckable = Remote.name
+
+cantCheck :: Checkable a => a -> e
+cantCheck v = error $ "unable to check " ++ descCheckable v

Remote/Helper/Special.hs

@@ -11,6 +11,8 @@ module Remote.Helper.Special (
 	Preparer,
 	Storer,
 	Retriever,
+	Remover,
+	CheckPresent,
 	simplyPrepare,
 	ContentSource,
 	checkPrepare,
@@ -21,6 +23,8 @@ module Remote.Helper.Special (
 	byteRetriever,
 	storeKeyDummy,
 	retreiveKeyFileDummy,
+	removeKeyDummy,
+	checkPresentDummy,
 	SpecialRemoteCfg(..),
 	specialRemoteCfg,
 	specialRemote,
@@ -36,6 +40,7 @@ import Config.Cost
 import Utility.Metered
 import Remote.Helper.Chunked as X
 import Remote.Helper.Encryptable as X hiding (encryptableRemote)
+import Remote.Helper.Messages
 import Annex.Content
 import Annex.Exception
 import qualified Git
@@ -114,16 +119,27 @@ byteRetriever :: (Key -> (L.ByteString -> Annex Bool) -> Annex Bool) -> Retrieve
 byteRetriever a k _m callback = a k (callback . ByteContent)
 
 {- The base Remote that is provided to specialRemote needs to have
- - storeKey and retreiveKeyFile methods, but they are never
+ - storeKey, retreiveKeyFile, removeKey, and checkPresent methods,
- - actually used (since specialRemote replaces them).
+ - but they are never actually used (since specialRemote replaces them).
  - Here are some dummy ones.
  -}
 storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool
 storeKeyDummy _ _ _ = return False
 retreiveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
 retreiveKeyFileDummy _ _ _ _ = return False
+removeKeyDummy :: Key -> Annex Bool
+removeKeyDummy _ = return False
+checkPresentDummy :: Key -> Annex Bool
+checkPresentDummy _ = error "missing checkPresent implementation"
 
-type RemoteModifier = RemoteConfig -> Preparer Storer -> Preparer Retriever -> Remote -> Remote
+type RemoteModifier
+	= RemoteConfig
+	-> Preparer Storer
+	-> Preparer Retriever
+	-> Preparer Remover
+	-> Preparer CheckPresent
+	-> Remote
+	-> Remote
 
 data SpecialRemoteCfg = SpecialRemoteCfg
 	{ chunkConfig :: ChunkConfig
@@ -139,13 +155,14 @@ specialRemote :: RemoteModifier
 specialRemote c = specialRemote' (specialRemoteCfg c) c
 
 specialRemote' :: SpecialRemoteCfg -> RemoteModifier
-specialRemote' cfg c preparestorer prepareretriever baser = encr
+specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckpresent baser = encr
   where
 	encr = baser
 		{ storeKey = \k _f p -> cip >>= storeKeyGen k p
 		, retrieveKeyFile = \k _f d p -> cip >>= retrieveKeyFileGen k d p
 		, retrieveKeyFileCheap = \k d -> cip >>= maybe
 			(retrieveKeyFileCheap baser k d)
+			-- retrieval of encrypted keys is never cheap
 			(\_ -> return False)
 		, removeKey = \k -> cip >>= removeKeyGen k
 		, checkPresent = \k -> cip >>= checkPresentGen k
@@ -160,8 +177,7 @@ specialRemote' cfg c preparestorer prepareretriever baser = encr
 	safely a = catchNonAsyncAnnex a (\e -> warning (show e) >> return False)
 
 	-- chunk, then encrypt, then feed to the storer
-	storeKeyGen k p enc =
+	storeKeyGen k p enc = safely $ preparestorer k $ safely . go
-		safely $ preparestorer k $ safely . go
 	  where
 		go (Just storer) = sendAnnex k rollback $ \src ->
 			displayprogress p k $ \p' ->
@@ -178,7 +194,7 @@ specialRemote' cfg c preparestorer prepareretriever baser = encr
 				readBytes $ \encb ->
 					storer (enck k) (ByteContent encb) p
 
-	-- call retriever to get chunks; decrypt them; stream to dest file
+	-- call retrieve-r to get chunks; decrypt them; stream to dest file
 	retrieveKeyFileGen k dest p enc =
 		safely $ prepareretriever k $ safely . go
 	  where
@@ -188,15 +204,17 @@ specialRemote' cfg c preparestorer prepareretriever baser = encr
 		go Nothing = return False
 		enck = maybe id snd enc
 
-	removeKeyGen k enc = removeChunks remover (uuid baser) chunkconfig enck k
+	removeKeyGen k enc = safely $ prepareremover k $ safely . go
 	  where
+		go (Just remover) = removeChunks remover (uuid baser) chunkconfig enck k
+		go Nothing = return False
 		enck = maybe id snd enc
-		remover = removeKey baser
 
-	checkPresentGen k enc = checkPresentChunks checker (uuid baser) chunkconfig enck k
+	checkPresentGen k enc = preparecheckpresent k go
 	  where
+	  	go (Just checker) = checkPresentChunks checker (uuid baser) chunkconfig enck k
+		go Nothing = cantCheck baser
 		enck = maybe id snd enc
-		checker = checkPresent baser
 
 	chunkconfig = chunkConfig cfg
 

Remote/Hook.hs

@@ -37,6 +37,8 @@ gen r u c gc = do
 	return $ Just $ specialRemote c
 		(simplyPrepare $ store hooktype)
 		(simplyPrepare $ retrieve hooktype)
+		(simplyPrepare $ remove hooktype)
+		(simplyPrepare $ checkKey r hooktype)
 		Remote {
 			uuid = u,
 			cost = cst,
@@ -44,8 +46,8 @@ gen r u c gc = do
 			storeKey = storeKeyDummy,
 			retrieveKeyFile = retreiveKeyFileDummy,
 			retrieveKeyFileCheap = retrieveCheap hooktype,
-			removeKey = remove hooktype,
+			removeKey = removeKeyDummy,
-			checkPresent = checkKey r hooktype,
+			checkPresent = checkPresentDummy,
 			checkPresentCheap = False,
 			whereisKey = Nothing,
 			remoteFsck = Nothing,
@@ -125,10 +127,10 @@ retrieve h = fileRetriever $ \d k _p ->
 retrieveCheap :: HookName -> Key -> FilePath -> Annex Bool
 retrieveCheap _ _ _ = return False
 
-remove :: HookName -> Key -> Annex Bool
+remove :: HookName -> Remover
 remove h k = runHook h "remove" k Nothing $ return True
 
-checkKey :: Git.Repo -> HookName -> Key -> Annex Bool
+checkKey :: Git.Repo -> HookName -> CheckPresent
 checkKey r h k = do
 	showAction $ "checking " ++ Git.repoDescribe r
 	v <- lookupHook h action

Remote/Rsync.hs

@@ -58,6 +58,8 @@ gen r u c gc = do
 	return $ Just $ specialRemote' specialcfg c
 		(simplyPrepare $ fileStorer $ store o)
 		(simplyPrepare $ fileRetriever $ retrieve o)
+		(simplyPrepare $ remove o)
+		(simplyPrepare $ checkKey r o)
 		Remote
 			{ uuid = u
 			, cost = cst
@@ -65,8 +67,8 @@ gen r u c gc = do
 			, storeKey = storeKeyDummy
 			, retrieveKeyFile = retreiveKeyFileDummy
 			, retrieveKeyFileCheap = retrieveCheap o
-			, removeKey = remove o
+			, removeKey = removeKeyDummy
-			, checkPresent = checkKey r o
+			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
 			, whereisKey = Nothing
 			, remoteFsck = Nothing
@@ -186,7 +188,7 @@ retrieve o f k p =
 retrieveCheap :: RsyncOpts -> Key -> FilePath -> Annex Bool
 retrieveCheap o k f = ifM (preseedTmp k f) ( rsyncRetrieve o k f Nothing , return False )
 
-remove :: RsyncOpts -> Key -> Annex Bool
+remove :: RsyncOpts -> Remover
 remove o k = do
 	ps <- sendParams
 	withRsyncScratchDir $ \tmp -> liftIO $ do
@@ -214,7 +216,7 @@ remove o k = do
 		, dir </> keyFile k </> "***"
 		]
 
-checkKey :: Git.Repo -> RsyncOpts -> Key -> Annex Bool
+checkKey :: Git.Repo -> RsyncOpts -> CheckPresent
 checkKey r o k = do
 	showAction $ "checking " ++ Git.repoDescribe r
 	-- note: Does not currently differentiate between rsync failing

Remote/S3.hs

@@ -47,6 +47,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 	new cst = Just $ specialRemote c
 		(prepareStore this)
 		(prepareRetrieve this)
+		(simplyPrepare $ remove this c)
+		(simplyPrepare $ checkKey this)
 		this
 	  where
 		this = Remote {
@@ -55,9 +57,9 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			name = Git.repoDescribe r,
 			storeKey = storeKeyDummy,
 			retrieveKeyFile = retreiveKeyFileDummy,
-			retrieveKeyFileCheap = retrieveCheap this,
+			retrieveKeyFileCheap = retrieveCheap,
-			removeKey = remove this c,
+			removeKey = removeKeyDummy,
-			checkPresent = checkKey this,
+			checkPresent = checkPresentDummy,
 			checkPresentCheap = False,
 			whereisKey = Nothing,
 			remoteFsck = Nothing,
@@ -150,13 +152,13 @@ prepareRetrieve r = resourcePrepare (const $ s3Action r False) $ \(conn, bucket)
 		liftIO (getObject conn $ bucketKey r bucket k)
 			>>= either s3Error (sink . obj_data)
 
-retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
+retrieveCheap :: Key -> FilePath -> Annex Bool
-retrieveCheap _ _ _ = return False
+retrieveCheap _ _ = return False
 
 {- Internet Archive doesn't easily allow removing content.
  - While it may remove the file, there are generally other files
  - derived from it that it does not remove. -}
-remove :: Remote -> RemoteConfig -> Key -> Annex Bool
+remove :: Remote -> RemoteConfig -> Remover
 remove r c k
 	| isIA c = do
 		warning "Cannot remove content from the Internet Archive"
@@ -167,7 +169,7 @@ remove' :: Remote -> Key -> Annex Bool
 remove' r k = s3Action r False $ \(conn, bucket) ->
 	s3Bool =<< liftIO (deleteObject conn $ bucketKey r bucket k)
 
-checkKey :: Remote -> Key -> Annex Bool
+checkKey :: Remote -> CheckPresent
 checkKey r k = s3Action r noconn $ \(conn, bucket) -> do
 	showAction $ "checking " ++ name r
 	res <- liftIO $ getObjectInfo conn $ bucketKey r bucket k