From b50ee9cd0cc17b06cd51f1a79e81a0210315f798 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 13 May 2020 11:50:31 -0400
Subject: [PATCH] remove Preparer abstraction

That had almost no benefit at all, and complicated things quite a lot.

What I proably wanted this to be was something like ResourceT, but it
was not. The few remotes that actually need some preparation done only
once and reused used a MVar and not Preparer.
---
 Remote/Adb.hs                     |  8 ++--
 Remote/Bup.hs                     |  8 ++--
 Remote/Ddar.hs                    |  8 ++--
 Remote/Directory.hs               | 20 ++++-----
 Remote/Directory/LegacyChunked.hs |  7 ++--
 Remote/External.hs                |  8 ++--
 Remote/GCrypt.hs                  |  8 ++--
 Remote/GitLFS.hs                  |  8 ++--
 Remote/Glacier.hs                 | 37 ++++++++---------
 Remote/Helper/Special.hs          | 67 +++++++++----------------------
 Remote/Hook.hs                    |  8 ++--
 Remote/Rsync.hs                   |  8 ++--
 Remote/S3.hs                      |  8 ++--
 Remote/WebDAV.hs                  |  8 ++--
 Types/StoreRetrieve.hs            |  4 --
 15 files changed, 93 insertions(+), 122 deletions(-)

diff --git a/Remote/Adb.hs b/Remote/Adb.hs
index e95905b01a..69b1472b59 100644
--- a/Remote/Adb.hs
+++ b/Remote/Adb.hs
@@ -108,10 +108,10 @@ gen r u rc gc rs = do
 		, remoteStateHandle = rs
 		}
 	return $ Just $ specialRemote c
-		(simplyPrepare $ store serial adir)
-		(simplyPrepare $ retrieve serial adir)
-		(simplyPrepare $ remove serial adir)
-		(simplyPrepare $ checkKey this serial adir)
+		(store serial adir)
+		(retrieve serial adir)
+		(remove serial adir)
+		(checkKey this serial adir)
 		this
   where
 	adir = maybe (giveup "missing androiddirectory") AndroidPath
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 51c0ebd295..ee6424b8f5 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -105,10 +105,10 @@ gen r u rc gc rs = do
 		{ chunkConfig = NoChunks
 		}
 	return $ Just $ specialRemote' specialcfg c
-		(simplyPrepare $ store this buprepo)
-		(simplyPrepare $ retrieve buprepo)
-		(simplyPrepare $ remove buprepo)
-		(simplyPrepare $ checkKey r bupr')
+		(store this buprepo)
+		(retrieve buprepo)
+		(remove buprepo)
+		(checkKey r bupr')
 		this
   where
 	buprepo = fromMaybe (giveup "missing buprepo") $ remoteAnnexBupRepo gc
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index c8847e1f94..bc031c458d 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -60,10 +60,10 @@ gen r u rc gc rs = do
 		{ chunkConfig = NoChunks
 		}
 	return $ Just $ specialRemote' specialcfg c
-		(simplyPrepare $ store ddarrepo)
-		(simplyPrepare $ retrieve ddarrepo)
-		(simplyPrepare $ remove ddarrepo)
-		(simplyPrepare $ checkKey ddarrepo)
+		(store ddarrepo)
+		(retrieve ddarrepo)
+		(remove ddarrepo)
+		(checkKey ddarrepo)
 		(this c cst)
   where
 	this c cst = Remote
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 0388ceda88..2ff2180542 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -60,10 +60,10 @@ gen r u rc gc rs = do
 	cst <- remoteCost gc cheapRemoteCost
 	let chunkconfig = getChunkConfig c
 	return $ Just $ specialRemote c
-		(prepareStore dir chunkconfig)
+		(storeKeyM dir chunkconfig)
 		(retrieveKeyFileM dir chunkconfig)
-		(simplyPrepare $ removeKeyM dir)
-		(simplyPrepare $ checkPresentM dir chunkconfig)
+		(removeKeyM dir)
+		(checkPresentM dir chunkconfig)
 		Remote
 			{ uuid = u
 			, cost = cst
@@ -154,10 +154,12 @@ storeDir d k = addTrailingPathSeparator $
 
 {- Check if there is enough free disk space in the remote's directory to
  - store the key. Note that the unencrypted key size is checked. -}
-prepareStore :: FilePath -> ChunkConfig -> Preparer Storer
-prepareStore d chunkconfig = checkPrepare (checkDiskSpaceDirectory d)
-	(byteStorer $ store d chunkconfig)
-  where
+storeKeyM :: FilePath -> ChunkConfig -> Storer
+storeKeyM d chunkconfig k c m = 
+	ifM (checkDiskSpaceDirectory d k)
+		( byteStorer (store d chunkconfig) k c m
+		, giveup "Not enough free disk space."
+		)
 
 checkDiskSpaceDirectory :: FilePath -> Key -> Annex Bool
 checkDiskSpaceDirectory d k = do
@@ -198,9 +200,9 @@ finalizeStoreGeneric d tmp dest = do
 		mapM_ preventWrite =<< dirContents dest
 		preventWrite dest
 
-retrieveKeyFileM :: FilePath -> ChunkConfig -> Preparer Retriever
+retrieveKeyFileM :: FilePath -> ChunkConfig -> Retriever
 retrieveKeyFileM d (LegacyChunks _) = Legacy.retrieve locations d
-retrieveKeyFileM d _ = simplyPrepare $ byteRetriever $ \k sink ->
+retrieveKeyFileM d _ = byteRetriever $ \k sink ->
 	sink =<< liftIO (L.readFile =<< getLocation d k)
 
 retrieveKeyFileCheapM :: FilePath -> ChunkConfig -> Key -> AssociatedFile -> FilePath -> Annex Bool
diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs
index 0943f63234..d8df2f1a54 100644
--- a/Remote/Directory/LegacyChunked.hs
+++ b/Remote/Directory/LegacyChunked.hs
@@ -88,11 +88,11 @@ store repotop chunksize finalizer k b p = storeHelper repotop finalizer k $ \des
  - Done very innefficiently, by writing to a temp file.
  - :/ This is legacy code..
  -}
-retrieve :: (FilePath -> Key -> [FilePath]) -> FilePath -> Preparer Retriever
-retrieve locations d basek a = withOtherTmp $ \tmpdir -> do
+retrieve :: (FilePath -> Key -> [FilePath]) -> FilePath -> Retriever
+retrieve locations d basek p c = withOtherTmp $ \tmpdir -> do
 	showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow."
 	let tmp = tmpdir </> fromRawFilePath (keyFile basek) ++ ".directorylegacy.tmp"
-	a $ Just $ byteRetriever $ \k sink -> do
+	let go = \k sink -> do
 		liftIO $ void $ withStoredFiles d locations k $ \fs -> do
 			forM_ fs $
 				S.appendFile tmp <=< S.readFile
@@ -100,6 +100,7 @@ retrieve locations d basek a = withOtherTmp $ \tmpdir -> do
 		b <- liftIO $ L.readFile tmp
 		liftIO $ nukeFile tmp
 		sink b
+	byteRetriever go basek p c
 
 checkKey :: FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> Annex Bool
 checkKey d locations k = liftIO $ withStoredFiles d locations k $
diff --git a/Remote/External.hs b/Remote/External.hs
index 4995ef50ee..fa022d8818 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -154,10 +154,10 @@ gen r u rc gc rs
 			, remoteStateHandle = rs
 			}
 		return $ Just $ specialRemote c
-			(simplyPrepare tostore)
-			(simplyPrepare toretrieve)
-			(simplyPrepare toremove)
-			(simplyPrepare tocheckkey)
+			tostore
+			toretrieve
+			toremove
+			tocheckkey
 			rmt
 	externaltype = fromMaybe (giveup "missing externaltype") (remoteAnnexExternalType gc)
 
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 13c6db9364..d96ffc638a 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -159,10 +159,10 @@ gen' r u c gc rs = do
 		, remoteStateHandle = rs
 	}
 	return $ Just $ specialRemote' specialcfg c
-		(simplyPrepare $ store this rsyncopts)
-		(simplyPrepare $ retrieve this rsyncopts)
-		(simplyPrepare $ remove this rsyncopts)
-		(simplyPrepare $ checkKey this rsyncopts)
+		(store this rsyncopts)
+		(retrieve this rsyncopts)
+		(remove this rsyncopts)
+		(checkKey this rsyncopts)
 		this
   where
 	specialcfg
diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs
index 95d1803fb8..1c7346b191 100644
--- a/Remote/GitLFS.hs
+++ b/Remote/GitLFS.hs
@@ -91,10 +91,10 @@ gen r u rc gc rs = do
 		{ chunkConfig = NoChunks
 		}
 	return $ Just $ specialRemote' specialcfg c
-		(simplyPrepare $ store rs h)
-		(simplyPrepare $ retrieve rs h)
-		(simplyPrepare $ remove h)
-		(simplyPrepare $ checkKey rs h)
+		(store rs h)
+		(retrieve rs h)
+		(remove h)
+		(checkKey rs h)
 		(this c cst)
   where
 	this c cst = Remote
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index 4c758d65be..b9c3aed281 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -65,10 +65,10 @@ gen r u rc gc rs = new
 	<*> remoteCost gc veryExpensiveRemoteCost
   where
 	new c cst = Just $ specialRemote' specialcfg c
-		(prepareStore this)
-		(prepareRetrieve this)
-		(simplyPrepare $ remove this)
-		(simplyPrepare $ checkKey this)
+		(store this)
+		(retrieve this)
+		(remove this)
+		(checkKey this)
 		this
 	  where
 		this = Remote
@@ -136,18 +136,19 @@ glacierSetup' ss u mcreds c gc = do
 		, (vaultField, Proposed defvault)
 		]
 
-prepareStore :: Remote -> Preparer Storer
-prepareStore r = checkPrepare nonEmpty (byteStorer $ store r)
+store :: Remote -> Storer
+store r k b p = do
+	checkNonEmpty k
+	byteStorer (store' r) k b p
 
-nonEmpty :: Key -> Annex Bool
-nonEmpty k
-	| fromKey keySize k == Just 0 = do
-		warning "Cannot store empty files in Glacier."
-		return False
-	| otherwise = return True
+checkNonEmpty :: Key -> Annex ()
+checkNonEmpty k
+	| fromKey keySize k == Just 0 =
+		giveup "Cannot store empty files in Glacier."
+	| otherwise = return ()
 
-store :: Remote -> Key -> L.ByteString -> MeterUpdate -> Annex Bool
-store r k b p = go =<< glacierEnv c gc u
+store' :: Remote -> Key -> L.ByteString -> MeterUpdate -> Annex Bool
+store' r k b p = go =<< glacierEnv c gc u
   where
 	c = config r
 	gc = gitconfig r
@@ -167,11 +168,11 @@ store r k b p = go =<< glacierEnv c gc u
 				meteredWrite p h b
 				return True
 
-prepareRetrieve :: Remote -> Preparer Retriever
-prepareRetrieve = simplyPrepare . byteRetriever . retrieve
+retrieve :: Remote -> Retriever
+retrieve = byteRetriever . retrieve'
 
-retrieve :: Remote -> Key -> (L.ByteString -> Annex Bool) -> Annex Bool
-retrieve r k sink = go =<< glacierEnv c gc u
+retrieve' :: Remote -> Key -> (L.ByteString -> Annex Bool) -> Annex Bool
+retrieve' r k sink = go =<< glacierEnv c gc u
   where
 	c = config r
 	gc = gitconfig r
diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs
index a8b945c723..dd3bcebdd2 100644
--- a/Remote/Helper/Special.hs
+++ b/Remote/Helper/Special.hs
@@ -11,15 +11,11 @@ module Remote.Helper.Special (
 	findSpecialRemotes,
 	gitConfigSpecialRemote,
 	mkRetrievalVerifiableKeysSecure,
-	Preparer,
 	Storer,
 	Retriever,
 	Remover,
 	CheckPresent,
-	simplyPrepare,
 	ContentSource,
-	checkPrepare,
-	resourcePrepare,
 	fileStorer,
 	byteStorer,
 	fileRetriever,
@@ -50,7 +46,6 @@ import Config.Cost
 import Utility.Metered
 import Remote.Helper.Chunked as X
 import Remote.Helper.Encryptable as X
-import Remote.Helper.Messages
 import Annex.Content
 import Messages.Progress
 import qualified Git
@@ -93,22 +88,6 @@ mkRetrievalVerifiableKeysSecure gc
 	| remoteAnnexAllowUnverifiedDownloads gc = RetrievalAllKeysSecure
 	| otherwise = RetrievalVerifiableKeysSecure
 
--- Use when nothing needs to be done to prepare a helper.
-simplyPrepare :: helper -> Preparer helper
-simplyPrepare helper _ a = a $ Just helper
-
--- Use to run a check when preparing a helper.
-checkPrepare :: (Key -> Annex Bool) -> helper -> Preparer helper
-checkPrepare checker helper k a = ifM (checker k)
-	( a (Just helper)
-	, a Nothing
-	)
-
--- Use to acquire a resource when preparing a helper.
-resourcePrepare :: (Key -> (r -> Annex Bool) -> Annex Bool) -> (r -> helper) -> Preparer helper
-resourcePrepare withr helper k a = withr k $ \r ->
-	a (Just (helper r))
-
 -- A Storer that expects to be provided with a file containing
 -- the content of the key to store.
 fileStorer :: (Key -> FilePath -> MeterUpdate -> Annex Bool) -> Storer
@@ -152,10 +131,10 @@ checkPresentDummy _ = error "missing checkPresent implementation"
 
 type RemoteModifier
 	= ParsedRemoteConfig
-	-> Preparer Storer
-	-> Preparer Retriever
-	-> Preparer Remover
-	-> Preparer CheckPresent
+	-> Storer
+	-> Retriever
+	-> Remover
+	-> CheckPresent
 	-> Remote
 	-> Remote
 
@@ -185,7 +164,7 @@ specialRemote :: RemoteModifier
 specialRemote c = specialRemote' (specialRemoteCfg c) c
 
 specialRemote' :: SpecialRemoteCfg -> RemoteModifier
-specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckpresent baser = encr
+specialRemote' cfg c storer retriever remover checkpresent baser = encr
   where
 	encr = baser
 		{ storeKey = \k _f p -> cip >>= storeKeyGen k p
@@ -229,21 +208,17 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
 	safely a = catchNonAsync a (\e -> warning (show e) >> return False)
 
 	-- chunk, then encrypt, then feed to the storer
-	storeKeyGen k p enc = safely $ preparestorer k $ safely . go
+	storeKeyGen k p enc = safely $ sendAnnex k rollback $ \src ->
+		displayprogress p k (Just src) $ \p' ->
+			storeChunks (uuid baser) chunkconfig enck k src p'
+				(storechunk enc)
+				checkpresent
 	  where
-		go (Just storer) = preparecheckpresent k $ safely . go' storer
-		go Nothing = return False
-		go' storer (Just checker) = sendAnnex k rollback $ \src ->
-			displayprogress p k (Just src) $ \p' ->
-				storeChunks (uuid baser) chunkconfig enck k src p'
-					(storechunk enc storer)
-					checker
-		go' _ Nothing = return False
 		rollback = void $ removeKey encr k
 		enck = maybe id snd enc
 
-	storechunk Nothing storer k content p = storer k content p
-	storechunk (Just (cipher, enck)) storer k content p = do
+	storechunk Nothing k content p = storer k content p
+	storechunk (Just (cipher, enck)) k content p = do
 		cmd <- gpgCmd <$> Annex.getGitConfig
 		withBytes content $ \b ->
 			encrypt cmd encr cipher (feedBytes b) $
@@ -251,25 +226,21 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
 					storer (enck k) (ByteContent encb) p
 
 	-- call retriever to get chunks; decrypt them; stream to dest file
-	retrieveKeyFileGen k dest p enc =
-		safely $ prepareretriever k $ safely . go
-	  where
-		go (Just retriever) = displayprogress p k Nothing $ \p' ->
+	retrieveKeyFileGen k dest p enc = safely $
+		displayprogress p k Nothing $ \p' ->
 			retrieveChunks retriever (uuid baser) chunkconfig
 				enck k dest p' (sink dest enc encr)
-		go Nothing = return False
+	  where
 		enck = maybe id snd enc
 
-	removeKeyGen k enc = safely $ prepareremover k $ safely . go
+	removeKeyGen k enc = safely $
+		removeChunks remover (uuid baser) chunkconfig enck k
 	  where
-		go (Just remover) = removeChunks remover (uuid baser) chunkconfig enck k
-		go Nothing = return False
 		enck = maybe id snd enc
 
-	checkPresentGen k enc = preparecheckpresent k go
+	checkPresentGen k enc = 
+		checkPresentChunks checkpresent (uuid baser) chunkconfig enck k
 	  where
-		go (Just checker) = checkPresentChunks checker (uuid baser) chunkconfig enck k
-		go Nothing = cantCheck baser
 		enck = maybe id snd enc
 
 	chunkconfig = chunkConfig cfg
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 71c06de3a2..4bddaaaf1a 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -50,10 +50,10 @@ gen r u rc gc rs = do
 	c <- parsedRemoteConfig remote rc
 	cst <- remoteCost gc expensiveRemoteCost
 	return $ Just $ specialRemote c
-		(simplyPrepare $ store hooktype)
-		(simplyPrepare $ retrieve hooktype)
-		(simplyPrepare $ remove hooktype)
-		(simplyPrepare $ checkKey r hooktype)
+		(store hooktype)
+		(retrieve hooktype)
+		(remove hooktype)
+		(checkKey r hooktype)
 		Remote
 			{ uuid = u
 			, cost = cst
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 04d01e60a3..475c85f844 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -80,10 +80,10 @@ gen r u rc gc rs = do
 		-- Rsync displays its own progress.
 		{ displayProgress = False }
 	return $ Just $ specialRemote' specialcfg c
-		(simplyPrepare $ fileStorer $ store o)
-		(simplyPrepare $ fileRetriever $ retrieve o)
-		(simplyPrepare $ remove o)
-		(simplyPrepare $ checkKey r o)
+		(fileStorer $ store o)
+		(fileRetriever $ retrieve o)
+		(remove o)
+		(checkKey r o)
 		Remote
 			{ uuid = u
 			, cost = cst
diff --git a/Remote/S3.hs b/Remote/S3.hs
index e3ea492f20..7a4c73d247 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -182,10 +182,10 @@ gen r u rc gc rs = do
 	return $ new c cst info hdl magic
   where
 	new c cst info hdl magic = Just $ specialRemote c
-		(simplyPrepare $ store hdl this info magic)
-		(simplyPrepare $ retrieve hdl this rs c info)
-		(simplyPrepare $ remove hdl this info)
-		(simplyPrepare $ checkKey hdl this rs c info)
+		(store hdl this info magic)
+		(retrieve hdl this rs c info)
+		(remove hdl this info)
+		(checkKey hdl this rs c info)
 		this
 	  where
 		this = Remote
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 59b843d6ff..27426c951d 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -73,10 +73,10 @@ gen r u rc gc rs = do
 		<*> mkDavHandleVar c gc u
   where
 	new c cst hdl = Just $ specialRemote c
-		(simplyPrepare $ store hdl chunkconfig)
-		(simplyPrepare $ retrieve hdl chunkconfig)
-		(simplyPrepare $ remove hdl)
-		(simplyPrepare $ checkKey hdl this chunkconfig)
+		(store hdl chunkconfig)
+		(retrieve hdl chunkconfig)
+		(remove hdl)
+		(checkKey hdl this chunkconfig)
 		this
 	  where
 		this = Remote
diff --git a/Types/StoreRetrieve.hs b/Types/StoreRetrieve.hs
index e8faae1d88..e9d9ad0660 100644
--- a/Types/StoreRetrieve.hs
+++ b/Types/StoreRetrieve.hs
@@ -12,10 +12,6 @@ import Utility.Metered
 
 import qualified Data.ByteString.Lazy as L
 
--- Prepares for and then runs an action that will act on a Key's
--- content, passing it a helper when the preparation is successful.
-type Preparer helper = Key -> (Maybe helper -> Annex Bool) -> Annex Bool
-
 -- A source of a Key's content.
 data ContentSource
 	= FileContent FilePath