convert gcrypt to new regime, including chunking

Some reorg of Remote.Rsync code to export the things gcrypt needs.

2 files changed, 81 insertions, 95 deletions

diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 523175fdc..faf45b1d9 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -29,7 +29,6 @@ import qualified Git.GCrypt
 import qualified Git.Construct
 import qualified Git.Types as Git ()
 import qualified Annex.Branch
-import qualified Annex.Content
 import Config
 import Config.Cost
 import Remote.Helper.Git
@@ -38,7 +37,6 @@ import Remote.Helper.Special
 import Remote.Helper.Messages
 import qualified Remote.Helper.Ssh as Ssh
 import Utility.Metered
-import Crypto
 import Annex.UUID
 import Annex.Ssh
 import qualified Remote.Rsync
@@ -47,7 +45,6 @@ import Utility.Tmp
 import Logs.Remote
 import Logs.Transfer
 import Utility.Gpg
-import Annex.Content
 
 remote :: RemoteType
 remote = RemoteType {
@@ -101,8 +98,8 @@ gen' r u c gc = do
 		{ uuid = u
 		, cost = cst
 		, name = Git.repoDescribe r
-		, storeKey = \_ _ _ -> noCrypto
-		, retrieveKeyFile = \_ _ _ _ -> noCrypto
+		, storeKey = storeKeyDummy
+		, retrieveKeyFile = retreiveKeyFileDummy
 		, retrieveKeyFileCheap = \_ _ -> return False
 		, removeKey = remove this rsyncopts
 		, hasKey = checkPresent this rsyncopts
@@ -118,10 +115,14 @@ gen' r u c gc = do
 		, availability = availabilityCalc r
 		, remotetype = remote
 	}
-	return $ Just $ encryptableRemote c
-		(store this rsyncopts)
-		(retrieve this rsyncopts)
+	return $ Just $ specialRemote' specialcfg c
+		(simplyPrepare $ store this rsyncopts)
+		(simplyPrepare $ retrieve this rsyncopts)
 		this
+  where
+	specialcfg = (specialRemoteCfg c)
+		-- Rsync displays its own progress.
+		{ displayProgress = False }
 
 rsyncTransportToObjects :: Git.Repo -> Annex ([CommandParam], String)
 rsyncTransportToObjects r = do
@@ -147,7 +148,7 @@ rsyncTransport r
 noCrypto :: Annex a
 noCrypto = error "cannot use gcrypt remote without encryption enabled"
 
-unsupportedUrl :: Annex a
+unsupportedUrl :: a
 unsupportedUrl = error "using non-ssh remote repo url with gcrypt is not supported"
 
 gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
@@ -249,14 +250,19 @@ setupRepo gcryptid r
 
 	denyNonFastForwards = "receive.denyNonFastForwards"
 
-shellOrRsync :: Remote -> Annex a -> Annex a -> Annex a
-shellOrRsync r ashell arsync = case method of
-	AccessShell -> ashell
-	_ -> arsync
+isShell :: Remote -> Bool
+isShell r = case method of
+	AccessShell -> True
+	_ -> False
   where
   	method = toAccessMethod $ fromMaybe "" $
 		remoteAnnexGCrypt $ gitconfig r
 
+shellOrRsync :: Remote -> Annex a -> Annex a -> Annex a
+shellOrRsync r ashell arsync
+	| isShell r = ashell
+	| otherwise = arsync
+
 {- Configure gcrypt to use the same list of keyids that
  - were passed to initremote as its participants.
  - Also, configure it to use a signing key that is in the list of
@@ -287,51 +293,32 @@ setGcryptEncryption c remotename = do
   where
 	remoteconfig n = ConfigKey $ n remotename
 
-store :: Remote -> Remote.Rsync.RsyncOpts -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
-store r rsyncopts (cipher, enck) k p
-	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $
-		metered (Just p) k $ \meterupdate -> spoolencrypted $ \h -> do
-			let dest = gCryptLocation r enck
+store :: Remote -> Remote.Rsync.RsyncOpts -> Storer
+store r rsyncopts
+	| not $ Git.repoIsUrl (repo r) = 
+		byteStorer $ \k b p -> guardUsable (repo r) False $ liftIO $ do
+			let dest = gCryptLocation r k
 			createDirectoryIfMissing True $ parentDir dest
-			readBytes (meteredWriteFile meterupdate dest) h
+			meteredWriteFile p dest b
 			return True
-	| Git.repoIsSsh (repo r) = shellOrRsync r storeshell storersync
+	| Git.repoIsSsh (repo r) = if isShell r
+		then fileStorer $ \k f p -> Ssh.rsyncHelper (Just p)
+			=<< Ssh.rsyncParamsRemote False r Upload k f Nothing
+		else fileStorer $ Remote.Rsync.store rsyncopts
 	| otherwise = unsupportedUrl
-  where
-  	gpgopts = getGpgEncParams r
-	storersync = undefined -- Remote.Rsync.storeEncrypted rsyncopts gpgopts (cipher, enck) k p
-	storeshell = withTmp enck $ \tmp ->
-		ifM (spoolencrypted $ readBytes $ \b -> catchBoolIO $ L.writeFile tmp b >> return True)
-			( Ssh.rsyncHelper (Just p)
-				=<< Ssh.rsyncParamsRemote False r Upload enck tmp Nothing
-			, return False
-			)
-	spoolencrypted a = Annex.Content.sendAnnex k noop $ \src ->
-		liftIO $ catchBoolIO $
-			encrypt gpgopts cipher (feedFile src) a
-
-retrieve :: Remote -> Remote.Rsync.RsyncOpts -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
-retrieve r rsyncopts (cipher, enck) k d p
-	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
-		retrievewith $ L.readFile src
-		return True
-	| Git.repoIsSsh (repo r) = shellOrRsync r retrieveshell retrieversync
+
+retrieve :: Remote -> Remote.Rsync.RsyncOpts -> Retriever
+retrieve r rsyncopts
+	| not $ Git.repoIsUrl (repo r) = byteRetriever $ \k sink ->
+		guardUsable (repo r) False $
+			sink =<< liftIO (L.readFile $ gCryptLocation r k)
+	| Git.repoIsSsh (repo r) = if isShell r
+		then fileRetriever $ \f k p ->
+			unlessM (Ssh.rsyncHelper (Just p) =<< Ssh.rsyncParamsRemote False r Download k f Nothing) $
+				error "rsync failed"
+		else fileRetriever $ Remote.Rsync.retrieve rsyncopts
 	| otherwise = unsupportedUrl
   where
-	src = gCryptLocation r enck
-	retrievewith a = metered (Just p) k $ \meterupdate -> liftIO $
-		a >>= \b -> 
-			decrypt cipher (feedBytes b)
-				(readBytes $ meteredWriteFile meterupdate d)
-	retrieversync = undefined -- Remote.Rsync.retrieveEncrypted rsyncopts (cipher, enck) k d p
-	retrieveshell = withTmp enck $ \tmp ->
-		ifM (Ssh.rsyncHelper (Just p) =<< Ssh.rsyncParamsRemote False r Download enck tmp Nothing)
-			( liftIO $ catchBoolIO $ do
-				decrypt cipher (feedFile tmp) $
-					readBytes $ L.writeFile d
-				return True
-			, return False
-			)
 
 remove :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex Bool
 remove r rsyncopts k
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index d0bacd585..421c451bd 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -9,6 +9,8 @@
 
 module Remote.Rsync (
 	remote,
+	store,
+	retrieve,
 	remove,
 	checkPresent,
 	withRsyncScratchDir,
@@ -54,8 +56,8 @@ gen r u c gc = do
 	let o = genRsyncOpts c gc transport url
 	let islocal = rsyncUrlIsPath $ rsyncUrl o
 	return $ Just $ specialRemote' specialcfg c
-		(simplyPrepare $ store o)
-		(simplyPrepare $ retrieve o)
+		(simplyPrepare $ fileStorer $ store o)
+		(simplyPrepare $ fileRetriever $ retrieve o)
 		Remote
 			{ uuid = u
 			, cost = cst
@@ -140,11 +142,44 @@ rsyncSetup mu _ c = do
 	gitConfigSpecialRemote u c' "rsyncurl" url
 	return (c', u)
 
-store :: RsyncOpts -> Storer
-store = fileStorer . rsyncSend
+{- To send a single key is slightly tricky; need to build up a temporary
+ - directory structure to pass to rsync so it can create the hash
+ - directories.
+ -
+ - This would not be necessary if the hash directory structure used locally
+ - was always the same as that used on the rsync remote. So if that's ever
+ - unified, this gets nicer.
+ - (When we have the right hash directory structure, we can just
+ - pass --include=X --include=X/Y --include=X/Y/file --exclude=*)
+ -}
+store :: RsyncOpts -> Key -> FilePath -> MeterUpdate -> Annex Bool
+store o k src meterupdate = withRsyncScratchDir $ \tmp -> do
+	let dest = tmp </> Prelude.head (keyPaths k)
+	liftIO $ createDirectoryIfMissing True $ parentDir dest
+	ok <- liftIO $ if canrename
+		then do
+			rename src dest
+			return True
+		else createLinkOrCopy src dest
+	ps <- sendParams
+	if ok
+		then showResumable $ rsyncRemote Upload o (Just meterupdate) $ ps ++
+			[ Param "--recursive"
+			, partialParams
+			-- tmp/ to send contents of tmp dir
+			, File $ addTrailingPathSeparator tmp
+			, Param $ rsyncUrl o
+			]
+		else return False
+  where
+ 	{- If the key being sent is encrypted or chunked, the file
+	 - containing its content is a temp file, and so can be
+	 - renamed into place. Otherwise, the file is the annexed
+	 - object file, and has to be copied or hard linked into place. -}
+	canrename = isEncKey k || isChunkKey k
 
-retrieve :: RsyncOpts -> Retriever
-retrieve o = fileRetriever $ \f k p ->
+retrieve :: RsyncOpts -> FilePath -> Key -> MeterUpdate -> Annex ()
+retrieve o f k p = 
 	unlessM (rsyncRetrieve o k f (Just p)) $
 		error "rsync failed"
 
@@ -249,39 +284,3 @@ rsyncRemote direction o callback params = do
 	opts
 		| direction == Download = rsyncDownloadOptions o
 		| otherwise = rsyncUploadOptions o
-
-{- To send a single key is slightly tricky; need to build up a temporary
- - directory structure to pass to rsync so it can create the hash
- - directories.
- -
- - This would not be necessary if the hash directory structure used locally
- - was always the same as that used on the rsync remote. So if that's ever
- - unified, this gets nicer.
- - (When we have the right hash directory structure, we can just
- - pass --include=X --include=X/Y --include=X/Y/file --exclude=*)
- -}
-rsyncSend :: RsyncOpts -> Key -> FilePath -> MeterUpdate -> Annex Bool
-rsyncSend o k src meterupdate = withRsyncScratchDir $ \tmp -> do
-	let dest = tmp </> Prelude.head (keyPaths k)
-	liftIO $ createDirectoryIfMissing True $ parentDir dest
-	ok <- liftIO $ if canrename
-		then do
-			rename src dest
-			return True
-		else createLinkOrCopy src dest
-	ps <- sendParams
-	if ok
-		then showResumable $ rsyncRemote Upload o (Just meterupdate) $ ps ++
-			[ Param "--recursive"
-			, partialParams
-			-- tmp/ to send contents of tmp dir
-			, File $ addTrailingPathSeparator tmp
-			, Param $ rsyncUrl o
-			]
-		else return False
-  where
- 	{- If the key being sent is encrypted or chunked, the file
-	 - containing its content is a temp file, and so can be
-	 - renamed into place. Otherwise, the file is the annexed
-	 - object file, and has to be copied or hard linked into place. -}
-	canrename = isEncKey k || isChunkKey k