From c88874a89db54402dbf6bdd56f6d0306f4303e53 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sun, 10 Aug 2014 14:52:58 -0400
Subject: testremote: Add testing of behavior when remote is not available

Added a mkUnavailable method, which a Remote can use to generate a version
of itself that is not available. Implemented for several, but not yet all
remotes.

This allows testing that checkPresent properly throws an exceptions when
it cannot check if a key is present or not. It also allows testing that the
other methods don't throw exceptions in these circumstances.

This immediately found several bugs, which this commit also fixes!

* git remotes using ssh accidentially had checkPresent return
  an exception, rather than throwing it
* The chunking code accidentially returned False rather than
  propigating an exception when there were no chunks and
  checkPresent threw an exception for the non-chunked key.

This commit was sponsored by Carlo Matteo Capocasa.
---
 Remote/Bup.hs            |  1 +
 Remote/Ddar.hs           |  1 +
 Remote/Directory.hs      |  9 +++++++--
 Remote/External.hs       |  4 +++-
 Remote/GCrypt.hs         |  5 +++--
 Remote/Git.hs            | 21 ++++++++++++++++++---
 Remote/Glacier.hs        |  3 ++-
 Remote/Helper/Chunked.hs |  7 ++++---
 Remote/Helper/Ssh.hs     | 12 ++++++------
 Remote/Hook.hs           |  4 +++-
 Remote/Rsync.hs          |  1 +
 Remote/S3.hs             |  3 ++-
 Remote/Tahoe.hs          |  3 ++-
 Remote/Web.hs            |  3 ++-
 Remote/WebDAV.hs         |  3 ++-
 15 files changed, 57 insertions(+), 23 deletions(-)

(limited to 'Remote')

diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 80fffc056..0de0e2946 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -72,6 +72,7 @@ gen r u c gc = do
 		, remotetype = remote
 		, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable
 		, readonly = False
+		, mkUnavailable = return Nothing
 		}
 	return $ Just $ specialRemote' specialcfg c
 		(simplyPrepare $ store this buprepo)
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index beeb4d7cc..fc226ddff 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -69,6 +69,7 @@ gen r u c gc = do
 		, remotetype = remote
 		, availability = if ddarLocal ddarrepo then LocallyAvailable else GloballyAvailable
 		, readonly = False
+		, mkUnavailable = return Nothing
 		}
 	ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc
 	specialcfg = (specialRemoteCfg c)
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index d9419757f..3137c9534 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -65,7 +65,9 @@ gen r u c gc = do
 			localpath = Just dir,
 			readonly = False,
 			availability = LocallyAvailable,
-			remotetype = remote
+			remotetype = remote,
+			mkUnavailable = gen r u c $
+				gc { remoteAnnexDirectory = Just "/dev/null" }
 		}
   where
 	dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
@@ -196,5 +198,8 @@ checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k
 checkKey d _ k = liftIO $
 	ifM (anyM doesFileExist (locations d k))
 		( return True
-		, error $ "directory " ++ d ++ " is not accessible"
+		, ifM (doesDirectoryExist d)
+			( return False
+			, error $ "directory " ++ d ++ " is not accessible"
+			)
 		)
diff --git a/Remote/External.hs b/Remote/External.hs
index 4fb760afd..6ba0e2f3a 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -65,7 +65,9 @@ gen r u c gc = do
 			gitconfig = gc,
 			readonly = False,
 			availability = avail,
-			remotetype = remote
+			remotetype = remote,
+			mkUnavailable = gen r u c $
+				gc { remoteAnnexExternalType = Just "!dne!" }
 		}
   where
 	externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 5edb3d022..a95f21669 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -120,6 +120,7 @@ gen' r u c gc = do
 		, readonly = Git.repoIsHttp r
 		, availability = availabilityCalc r
 		, remotetype = remote
+		, mkUnavailable = return Nothing
 	}
 	return $ Just $ specialRemote' specialcfg c
 		(simplyPrepare $ store this rsyncopts)
@@ -255,7 +256,7 @@ setupRepo gcryptid r
 
 	{-  Ask git-annex-shell to configure the repository as a gcrypt
 	 -  repository. May fail if it is too old. -}
-	gitannexshellsetup = Ssh.onRemote r (boolSystem, False)
+	gitannexshellsetup = Ssh.onRemote r (boolSystem, return False)
 		"gcryptsetup" [ Param gcryptid ] []
 
 	denyNonFastForwards = "receive.denyNonFastForwards"
@@ -389,7 +390,7 @@ getGCryptId fast r
 	| Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$>
 		liftIO (catchMaybeIO $ Git.Config.read r)
 	| not fast = extract . liftM fst <$> getM (eitherToMaybe <$>)
-		[ Ssh.onRemote r (Git.Config.fromPipe r, Left undefined) "configlist" [] []
+		[ Ssh.onRemote r (Git.Config.fromPipe r, return (Left undefined)) "configlist" [] []
 		, getConfigViaRsync r
 		]
 	| otherwise = return (Nothing, r)
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 20955ff5b..5416a5cda 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -55,6 +55,7 @@ import Creds
 import Control.Concurrent
 import Control.Concurrent.MSampleVar
 import qualified Data.Map as M
+import Network.URI
 
 remote :: RemoteType
 remote = RemoteType {
@@ -156,8 +157,22 @@ gen r u c gc
 			, readonly = Git.repoIsHttp r
 			, availability = availabilityCalc r
 			, remotetype = remote
+			, mkUnavailable = unavailable r u c gc
 			}
 
+unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
+unavailable r u c gc = gen r' u c gc
+  where
+	r' = case Git.location r of
+		Git.Local { Git.gitdir = d } ->
+			r { Git.location = Git.LocalUnknown d }
+		Git.Url url -> case uriAuthority url of
+			Just auth -> 
+				let auth' = auth { uriRegName = "!dne!" }
+				in r { Git.location = Git.Url (url { uriAuthority = Just auth' })}
+			Nothing -> r { Git.location = Git.Unknown }
+		_ -> r -- already unavailable
+
 {- Checks relatively inexpensively if a repository is available for use. -}
 repoAvail :: Git.Repo -> Annex Bool
 repoAvail r 
@@ -180,7 +195,7 @@ tryGitConfigRead :: Git.Repo -> Annex Git.Repo
 tryGitConfigRead r 
 	| haveconfig r = return r -- already read
 	| Git.repoIsSsh r = store $ do
-		v <- Ssh.onRemote r (pipedconfig, Left undefined) "configlist" [] []
+		v <- Ssh.onRemote r (pipedconfig, return (Left undefined)) "configlist" [] []
 		case v of
 			Right r'
 				| haveconfig r' -> return r'
@@ -298,8 +313,8 @@ inAnnex rmt key
 			)
 	checkremote = Ssh.inAnnex r key
 	checklocal = guardUsable r (cantCheck r) $
-		fromMaybe (cantCheck r)
-			<$> onLocal rmt (Annex.Content.inAnnexSafe key)
+		maybe (cantCheck r) return
+			=<< onLocal rmt (Annex.Content.inAnnexSafe key)
 
 keyUrls :: Remote -> Key -> [String]
 keyUrls r key = map tourl locs'
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index dd28def63..18038a79c 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -65,7 +65,8 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
 			localpath = Nothing,
 			readonly = False,
 			availability = GloballyAvailable,
-			remotetype = remote
+			remotetype = remote,
+			mkUnavailable = return Nothing
 		}
 	specialcfg = (specialRemoteCfg c)
 		-- Disabled until jobList gets support for chunks.
diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs
index 5e4ea111f..271978658 100644
--- a/Remote/Helper/Chunked.hs
+++ b/Remote/Helper/Chunked.hs
@@ -348,11 +348,12 @@ checkPresentChunks checker u chunkconfig encryptor basek
 		v <- check basek
 		case v of
 			Right True -> return True
+			Left e -> checklists (Just e) =<< chunkKeysOnly u basek
 			_ -> checklists Nothing =<< chunkKeysOnly u basek
 	| otherwise = checklists Nothing =<< chunkKeys u chunkconfig basek
   where
 	checklists Nothing [] = return False
-	checklists (Just deferrederror) [] = error deferrederror
+	checklists (Just deferrederror) [] = throwM deferrederror
 	checklists d (l:ls)
 		| not (null l) = do
 			v <- checkchunks l
@@ -362,14 +363,14 @@ checkPresentChunks checker u chunkconfig encryptor basek
 				Right False -> checklists Nothing ls
 		| otherwise = checklists d ls
 	
-	checkchunks :: [Key] -> Annex (Either String Bool)
+	checkchunks :: [Key] -> Annex (Either SomeException Bool)
 	checkchunks [] = return (Right True)
 	checkchunks (k:ks) = do
 		v <- check k
 		case v of
 			Right True -> checkchunks ks
 			Right False -> return $ Right False
-			Left e -> return $ Left $ show e
+			Left e -> return $ Left e
 
 	check = tryNonAsync . checker . encryptor
 
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index 42d77ea59..9f0a77178 100644
--- a/Remote/Helper/Ssh.hs
+++ b/Remote/Helper/Ssh.hs
@@ -69,7 +69,7 @@ git_annex_shell r command params fields
  - a specified error value. -}
 onRemote 
 	:: Git.Repo
-	-> (FilePath -> [CommandParam] -> IO a, a)
+	-> (FilePath -> [CommandParam] -> IO a, Annex a)
 	-> String
 	-> [CommandParam]
 	-> [(Field, String)]
@@ -78,7 +78,7 @@ onRemote r (with, errorval) command params fields = do
 	s <- git_annex_shell r command params fields
 	case s of
 		Just (c, ps) -> liftIO $ with c ps
-		Nothing -> return errorval
+		Nothing -> errorval
 
 {- Checks if a remote contains a key. -}
 inAnnex :: Git.Repo -> Key -> Annex Bool
@@ -86,14 +86,14 @@ inAnnex r k = do
 	showChecking r
 	onRemote r (check, cantCheck r) "inannex" [Param $ key2file k] []
   where
-	check c p = dispatch <$> safeSystem c p
-	dispatch ExitSuccess = True
-	dispatch (ExitFailure 1) = False
+	check c p = dispatch =<< safeSystem c p
+	dispatch ExitSuccess = return True
+	dispatch (ExitFailure 1) = return False
 	dispatch _ = cantCheck r
 
 {- Removes a key from a remote. -}
 dropKey :: Git.Repo -> Key -> Annex Bool
-dropKey r key = onRemote r (boolSystem, False) "dropkey"
+dropKey r key = onRemote r (boolSystem, return False) "dropkey"
 	[ Params "--quiet --force"
 	, Param $ key2file key
 	]
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index a2d096ecd..8e6ac439d 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -58,7 +58,9 @@ gen r u c gc = do
 			gitconfig = gc,
 			readonly = False,
 			availability = GloballyAvailable,
-			remotetype = remote
+			remotetype = remote,
+			mkUnavailable = gen r u c $
+				gc { remoteAnnexHookType = Just "!dne!" }
 		}
   where
 	hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index afd13abf0..f7b3461a0 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -82,6 +82,7 @@ gen r u c gc = do
 			, readonly = False
 			, availability = if islocal then LocallyAvailable else GloballyAvailable
 			, remotetype = remote
+			, mkUnavailable = return Nothing
 			}
   where
 	specialcfg = (specialRemoteCfg c)
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 1aba39245..ae1acd531 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -70,7 +70,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			localpath = Nothing,
 			readonly = False,
 			availability = GloballyAvailable,
-			remotetype = remote
+			remotetype = remote,
+			mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc
 		}
 
 s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index 6e52c0981..bde8ee9d7 100644
--- a/Remote/Tahoe.hs
+++ b/Remote/Tahoe.hs
@@ -83,7 +83,8 @@ gen r u c gc = do
 		localpath = Nothing,
 		readonly = False,
 		availability = GloballyAvailable,
-		remotetype = remote
+		remotetype = remote,
+		mkUnavailable = return Nothing
 	}
 
 tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
diff --git a/Remote/Web.hs b/Remote/Web.hs
index 7bdd8d185..04b453277 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -61,7 +61,8 @@ gen r _ c gc =
 		repo = r,
 		readonly = True,
 		availability = GloballyAvailable,
-		remotetype = remote
+		remotetype = remote,
+		mkUnavailable = return Nothing
 	}
 
 downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 4d5887c6c..bb8b4cc06 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -70,7 +70,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			localpath = Nothing,
 			readonly = False,
 			availability = GloballyAvailable,
-			remotetype = remote
+			remotetype = remote,
+			mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc
 		}
 		chunkconfig = getChunkConfig c
 
-- 
cgit v1.2.3


From cc54ff9e49260cd94f938e69e926a273e231ef4e Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Tue, 12 Aug 2014 15:35:29 -0400
Subject: S3, Glacier, WebDAV: Fix bug that prevented accessing the creds when
 the repository was configured with encryption=shared embedcreds=yes.

Since encryption=shared, the encryption key is stored in the git repo, so
there is no point at all in encrypting the creds, also stored in the git
repo with that key. So `initremote` doesn't. The creds are simply stored
base-64 encoded.

However, it then tried to always decrypt creds when encryption was used..
---
 Creds.hs                     | 16 ++++++++++------
 Remote/Helper/Encryptable.hs |  9 ++++++---
 debian/changelog             |  2 ++
 3 files changed, 18 insertions(+), 9 deletions(-)

(limited to 'Remote')

diff --git a/Creds.hs b/Creds.hs
index 7273ed966..73d631ff7 100644
--- a/Creds.hs
+++ b/Creds.hs
@@ -23,7 +23,7 @@ import Annex.Perms
 import Utility.FileMode
 import Crypto
 import Types.Remote (RemoteConfig, RemoteConfigKey)
-import Remote.Helper.Encryptable (remoteCipher, embedCreds)
+import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds)
 import Utility.Env (getEnv)
 
 import qualified Data.ByteString.Lazy.Char8 as L
@@ -85,15 +85,19 @@ getRemoteCredPair c storage = maybe fromcache (return . Just) =<< fromenv
 	fromcache = maybe fromconfig (return . Just) =<< readCacheCredPair storage
 	fromconfig = case credPairRemoteKey storage of
 		Just key -> do
-			mcipher <- remoteCipher c
-			case (M.lookup key c, mcipher) of
-				(Nothing, _) -> return Nothing
-				(Just enccreds, Just cipher) -> do
+			mcipher <- remoteCipher' c
+			case (mcipher, M.lookup key c) of
+				(_, Nothing) -> return Nothing
+				(Just (_cipher, SharedCipher {}), Just bcreds) ->
+					-- When using a shared cipher, the
+					-- creds are not stored encrypted.
+					fromcreds $ fromB64 bcreds
+				(Just (cipher, _), Just enccreds) -> do
 					creds <- liftIO $ decrypt cipher
 						(feedBytes $ L.pack $ fromB64 enccreds)
 						(readBytes $ return . L.unpack)
 					fromcreds creds
-				(Just bcreds, Nothing) ->
+				(Nothing, Just bcreds) ->
 					fromcreds $ fromB64 bcreds
 		Nothing -> return Nothing
 	fromcreds creds = case decodeCredPair creds of
diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs
index dd032ce33..69216a793 100644
--- a/Remote/Helper/Encryptable.hs
+++ b/Remote/Helper/Encryptable.hs
@@ -71,18 +71,21 @@ encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
 {- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex
  - state. -}
 remoteCipher :: RemoteConfig -> Annex (Maybe Cipher)
-remoteCipher c = go $ extractCipher c
+remoteCipher = fmap fst <$$> remoteCipher'
+
+remoteCipher' :: RemoteConfig -> Annex (Maybe (Cipher, StorableCipher))
+remoteCipher' c = go $ extractCipher c
   where
 	go Nothing = return Nothing
 	go (Just encipher) = do
 		cache <- Annex.getState Annex.ciphers
 		case M.lookup encipher cache of
-			Just cipher -> return $ Just cipher
+			Just cipher -> return $ Just (cipher, encipher)
 			Nothing -> do
 				showNote "gpg"
 				cipher <- liftIO $ decryptCipher encipher
 				Annex.changeState (\s -> s { Annex.ciphers = M.insert encipher cipher cache })
-				return $ Just cipher
+				return $ Just (cipher, encipher)
 
 {- Checks if the remote's config allows storing creds in the remote's config.
  - 
diff --git a/debian/changelog b/debian/changelog
index 722e9347e..b1d53a841 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -33,6 +33,8 @@ git-annex (5.20140718) UNRELEASED; urgency=medium
   * direct: Fix ugly warning messages.
   * WORM backend: When adding a file in a subdirectory, avoid including the
     subdirectory in the key name.
+  * S3, Glacier, WebDAV: Fix bug that prevented accessing the creds
+    when the repository was configured with encryption=shared embedcreds=yes.
 
  -- Joey Hess <joeyh@debian.org>  Mon, 21 Jul 2014 14:41:26 -0400
 
-- 
cgit v1.2.3