test encrypted special remote

This involved adding a test harness to run gpg with a dummy key, and lots
of fun.

Utility/Gpg.hs

@@ -11,9 +11,9 @@ import qualified Data.ByteString.Lazy.Char8 as L
 import System.Posix.Types
 import Control.Applicative
 import Control.Concurrent
-import Control.Exception (finally)
+import Control.Exception (finally, bracket)
 import System.Exit
-import System.Environment
+import System.Posix.Env (setEnv, unsetEnv, getEnv)	
 
 import Common
 
@@ -24,8 +24,8 @@ stdParams :: [CommandParam] -> IO [String]
 stdParams params = do
 	-- Enable batch mode if GPG_AGENT_INFO is set, to avoid extraneous
 	-- gpg output about password prompts.
-	e <- catchDefaultIO (getEnv "GPG_AGENT_INFO") ""
+	e <- getEnv "GPG_AGENT_INFO"
-	let batch = if null e then [] else ["--batch"]
+	let batch = if isNothing e then [] else ["--batch"]
 	return $ batch ++ defaults ++ toCommand params
 	where
 		-- be quiet, even about checking the trustdb
@@ -37,7 +37,7 @@ readStrict params = do
 	params' <- stdParams params
 	pOpen ReadFromPipe "gpg" params' hGetContentsStrict
 
-{- Runs gpg, piping an input value to it, and returninging its stdout,
+{- Runs gpg, piping an input value to it, and returning its stdout,
  - strictly. -}
 pipeStrict :: [CommandParam] -> String -> IO String
 pipeStrict params input = do
@@ -89,3 +89,106 @@ findPubKeys for = KeyIds . parse <$> readStrict params
 		parse = map keyIdField . filter pubKey . lines
 		pubKey = isPrefixOf "pub:"
 		keyIdField s = split ":" s !! 4
+
+
+
+{- A test key. This is provided pre-generated since generating a new gpg
+ - key is too much work (requires too much entropy) for a test suite to
+ - do.
+ -
+ - This key was generated with no exipiration date, and a small keysize. 
+ - It has an empty passphrase. -}
+testKeyId :: String
+testKeyId = "129D6E0AC537B9C7"
+testKey :: String
+testKey = keyBlock True
+	[ "mI0ETvFAZgEEAKnqwWgZqznMhi1RQExem2H8t3OyKDxaNN3rBN8T6LWGGqAYV4wT"
+	, "r8In5tfsnz64bKpE1Qi68JURFwYmthgUL9N48tbODU8t3xzijdjLOSaTyqkH1ik6"
+	, "EyulfKN63xLne9i4F9XqNwpiZzukXYbNfHkDA2yb0M6g4UFKLY/fNzGXABEBAAG0"
+	, "W2luc2VjdXJlIHRlc3Qga2V5ICh0aGlzIGlzIGEgdGVzdCBrZXksIGRvIG5vdCB1"
+	, "c2UgZm9yIGFjdHVhbCBlbmNyeXB0aW9uKSA8dGVzdEBleGFtcGxlLmNvbT6IuAQT"
+	, "AQgAIgUCTvFAZgIbAwYLCQgHAwIGFQgCCQoLBBYCAwECHgECF4AACgkQEp1uCsU3"
+	, "uceQ9wP/YMd1f0+/eLLcwGXNBvGqyVhUOfAKknO1bMzGbqTsq9g60qegy/cldqee"
+	, "xVxNfy0VN//JeMfgdcb8+RgJYLoaMrTy9CcsUcFPxtwN9tcLmsM0V2/fNmmFBO9t"
+	, "v75iH+zeFbNg0/FbPkHiN6Mjw7P2gXYKQXgTvQZBWaphk8oQlBm4jQRO8UBmAQQA"
+	, "vdi50M/WRCkOLt2RsUve8V8brMWYTJBJTTWoHUeRr82v4NCdX7OE1BsoVK8cy/1Q"
+	, "Y+gLOH9PqinuGGNWRmPV2Ju/RYn5H7sdewXA8E80xWhc4phHRMJ8Jjhg/GVPamkJ"
+	, "8B5zeKF0jcLFl7cuVdOyQakhoeDWJd0CyfW837nmPtMAEQEAAYifBBgBCAAJBQJO"
+	, "8UBmAhsMAAoJEBKdbgrFN7nHclAEAKBShuP/toH03atDUQTbGE34CA4yEC9BVghi"
+	, "7kviOZlOz2s8xAfp/8AYsrECx1kgbXcA7JD902eNyp7NzXsdJX0zJwHqiuZW0XlD"
+	, "T8ZJu4qrYRYgl/790WPESZ+ValvHD/fqkR38RF4tfxvyoMhhp0roGmJY33GASIG/"
+	, "+gQkDF9/"
+	, "=1k11"
+	]
+testSecretKey :: String
+testSecretKey = keyBlock False
+	[ "lQHYBE7xQGYBBACp6sFoGas5zIYtUUBMXpth/Ldzsig8WjTd6wTfE+i1hhqgGFeM"
+	, "E6/CJ+bX7J8+uGyqRNUIuvCVERcGJrYYFC/TePLWzg1PLd8c4o3Yyzkmk8qpB9Yp"
+	, "OhMrpXyjet8S53vYuBfV6jcKYmc7pF2GzXx5AwNsm9DOoOFBSi2P3zcxlwARAQAB"
+	, "AAP+PlRboxy7Z0XjuG70N6+CrzSddQbW5KCwgPFrxYsPk7sAPFcBkmRMVlv9vZpS"
+	, "phbP4bvDK+MrSntM51g+9uE802yhPhSWdmEbImiWfV2ucEhlLjD8gw7JDex9XZ0a"
+	, "EbTOV56wOsILuedX/jF/6i6IQzy5YmuMeo+ip1XQIsIN+80CAMyXepOBJgHw/gBD"
+	, "VdXh/l//vUkQQlhInQYwgkKbr0POCTdr8DM1qdKLcUD9Q1khgNRp0vZGGz+5xsrc"
+	, "KaODUlMCANSczLJcYWa8yPqB3S14yTe7qmtDiOS362+SeVUwQA7eQ06PcHLPsN+p"
+	, "NtWoHRfYazxrs+g0JvmoQOYdj4xSQy0CAMq7H/l6aeG1n8tpyMxqE7OvBOsvzdu5"
+	, "XS7I1AnwllVFgvTadVvqgf7b+hdYd91doeHDUGqSYO78UG1GgaBHJdylqrRbaW5z"
+	, "ZWN1cmUgdGVzdCBrZXkgKHRoaXMgaXMgYSB0ZXN0IGtleSwgZG8gbm90IHVzZSBm"
+	, "b3IgYWN0dWFsIGVuY3J5cHRpb24pIDx0ZXN0QGV4YW1wbGUuY29tPoi4BBMBCAAi"
+	, "BQJO8UBmAhsDBgsJCAcDAgYVCAIJCgsEFgIDAQIeAQIXgAAKCRASnW4KxTe5x5D3"
+	, "A/9gx3V/T794stzAZc0G8arJWFQ58AqSc7VszMZupOyr2DrSp6DL9yV2p57FXE1/"
+	, "LRU3/8l4x+B1xvz5GAlguhoytPL0JyxRwU/G3A321wuawzRXb982aYUE722/vmIf"
+	, "7N4Vs2DT8Vs+QeI3oyPDs/aBdgpBeBO9BkFZqmGTyhCUGZ0B2ARO8UBmAQQAvdi5"
+	, "0M/WRCkOLt2RsUve8V8brMWYTJBJTTWoHUeRr82v4NCdX7OE1BsoVK8cy/1QY+gL"
+	, "OH9PqinuGGNWRmPV2Ju/RYn5H7sdewXA8E80xWhc4phHRMJ8Jjhg/GVPamkJ8B5z"
+	, "eKF0jcLFl7cuVdOyQakhoeDWJd0CyfW837nmPtMAEQEAAQAD/RaVtFFTkF1udun7"
+	, "YOwzJvQXCO9OWHZvSdEeG4BUNdAwy4YWu0oZzKkBDBS6+lWILqqb/c28U4leUJ1l"
+	, "H+viz5svN9BWWyj/UpI00uwUo9JaIqalemwfLx6vsh69b54L1B4exLZHYGLvy/B3"
+	, "5T6bT0gpOE+53BRtKcJaOh/McQeJAgDTOCBU5weWOf6Bhqnw3Vr/gRfxntAz2okN"
+	, "gqz/h79mWbCc/lHKoYQSsrCdMiwziHSjXwvehUrdWE/AcomtW0vbAgDmGJqJ2fNr"
+	, "HvdsGx4Ld/BxyiZbCURJLUQ5CwzfHGIvBu9PMT8zM26NOSncaXRjxDna2Ggh8Uum"
+	, "ANEwbnhxFwZpAf9L9RLYIMTtAqwBjfXJg/lHcc2R+VP0hL5c8zFz+S+w7bRqINwL"
+	, "ff1JstKuHT2nJnu0ustK66by8YI3T0hDFFahnNCInwQYAQgACQUCTvFAZgIbDAAK"
+	, "CRASnW4KxTe5x3JQBACgUobj/7aB9N2rQ1EE2xhN+AgOMhAvQVYIYu5L4jmZTs9r"
+	, "PMQH6f/AGLKxAsdZIG13AOyQ/dNnjcqezc17HSV9MycB6ormVtF5Q0/GSbuKq2EW"
+	, "IJf+/dFjxEmflWpbxw/36pEd/EReLX8b8qDIYadK6BpiWN9xgEiBv/oEJAxffw=="
+	, "=LDsg"
+	]
+keyBlock :: Bool -> [String] -> String
+keyBlock public ls = unlines
+	[ "-----BEGIN PGP "++t++" KEY BLOCK-----"
+	, "Version: GnuPG v1.4.11 (GNU/Linux)"
+	, ""
+	, unlines ls
+	, "-----END PGP "++t++" KEY BLOCK-----"
+	]
+	where
+		t
+			| public = "PUBLIC"
+			| otherwise = "PRIVATE"
+
+{- Runs an action using gpg in a test harness, in which gpg does
+ - not use ~/.gpg/, but a directory with the test key set up to be used. -}
+testHarness :: IO a -> IO a
+testHarness a = do
+	orig <- getEnv var
+	bracket setup (cleanup orig) (const a)
+	where
+		var = "GNUPGHOME"		
+
+		setup = do
+			base <- getTemporaryDirectory
+			dir <- mktmpdir $ base </> "gpgtmpXXXXXX"
+			setEnv var dir True
+			_ <- pipeStrict [Params "--import -q"] $ unlines
+				[testSecretKey, testKey]
+			return dir
+		
+		cleanup orig tmpdir = removeDirectoryRecursive tmpdir >> reset orig
+                reset (Just v) = setEnv var v True
+                reset _ = unsetEnv var
+
+{- Tests the test harness. -}
+testTestHarness :: IO Bool
+testTestHarness = do
+	keys <- testHarness $ findPubKeys testKeyId
+	return $ KeyIds [testKeyId] == keys

debian/changelog

@@ -5,7 +5,7 @@ git-annex (3.20111212) UNRELEASED; urgency=low
   * Properly handle multiline git config values.
   * Fix the hook special remote, which bitrotted a while ago.
   * map: --fast disables use of dot to display map
-  * Test suite improvements. Current top-level test coverage: 68%
+  * Test suite improvements. Current top-level test coverage: 70%
 
  -- Joey Hess <joeyh@debian.org>  Mon, 12 Dec 2011 01:57:49 -0400
 

test.hs

@@ -42,6 +42,8 @@ import qualified Config
 import qualified Crypto
 import qualified Utility.Path
 import qualified Utility.FileMode
+import qualified Utility.Gpg
+import qualified Build.SysConfig
 
 -- for quickcheck
 instance Arbitrary Types.Key.Key where
@@ -116,6 +118,7 @@ blackbox = TestLabel "blackbox" $ TestList
 	, test_hook_remote
 	, test_directory_remote
 	, test_rsync_remote
+	, test_crypto
 	]
 
 test_init :: Test
@@ -623,6 +626,32 @@ test_rsync_remote = "git-annex rsync remote" ~: intmpclonerepo $ do
 	not <$> git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail"
 	annexed_present annexedfile
 
+test_crypto :: Test
+test_crypto = "git-annex crypto" ~: intmpclonerepo $
+	-- gpg is not a build dependency, so only test when it's available
+	when Build.SysConfig.gpg $ do
+		Utility.Gpg.testTestHarness @? "test harness self-test failed"
+		Utility.Gpg.testHarness $ do
+			createDirectory "dir"
+			let initremote = git_annex "initremote"
+				[ "foo"
+				, "type=directory"
+				, "encryption=" ++ Utility.Gpg.testKeyId
+				, "directory=dir"
+				]
+			initremote @? "initremote failed"
+			initremote @? "initremote failed when run twice in a row"
+			git_annex "get" [annexedfile] @? "get of file failed"
+			annexed_present annexedfile
+			git_annex "copy" [annexedfile, "--to", "foo"] @? "copy --to encrypted remote failed"
+			annexed_present annexedfile
+			git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed"
+			annexed_notpresent annexedfile
+			git_annex "move" [annexedfile, "--from", "foo"] @? "move --from encrypted remote failed"
+			annexed_present annexedfile
+			not <$> git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail"
+			annexed_present annexedfile	
+
 -- This is equivilant to running git-annex, but it's all run in-process
 -- so test coverage collection works.
 git_annex :: String -> [String] -> IO Bool