testremote: New command to test uploads/downloads to a remote.

This only performs some basic tests so far; no testing of chunking or
resuming. Also, the existing encryption type of the remote is used; it
would be good later to derive an encrypted and a non-encrypted version of
the remote and test them both.

This commit was sponsored by Joseph Liu.

Backend/Hash.hs

@@ -7,7 +7,10 @@
 
 {-# LANGUAGE CPP #-}
 
-module Backend.Hash (backends) where
+module Backend.Hash (
+	backends,
+	testKeyBackend,
+) where
 
 import Common.Annex
 import qualified Annex
@@ -36,10 +39,10 @@ hashes = concat
 
 {- The SHA256E backend is the default, so genBackendE comes first. -}
 backends :: [Backend]
-backends = catMaybes $ map genBackendE hashes ++ map genBackend hashes
+backends = map genBackendE hashes ++ map genBackend hashes
 
-genBackend :: Hash -> Maybe Backend
+genBackend :: Hash -> Backend
-genBackend hash = Just Backend
+genBackend hash = Backend
 	{ name = hashName hash
 	, getKey = keyValue hash
 	, fsckKey = Just $ checkKeyChecksum hash
@@ -48,10 +51,8 @@ genBackend hash = Just Backend
 	, isStableKey = const True
 	}
 
-genBackendE :: Hash -> Maybe Backend
+genBackendE :: Hash -> Backend
-genBackendE hash = do
+genBackendE hash = (genBackend hash)
-	b <- genBackend hash
-	return $ b 
 	{ name = hashNameE hash
 	, getKey = keyValueE hash
 	}
@@ -176,3 +177,18 @@ skeinHasher hashsize
 	| hashsize == 512 = show . skein512
 #endif
 	| otherwise = error $ "unsupported skein size " ++ show hashsize
+
+{- A varient of the SHA256E backend, for testing that needs special keys
+ - that cannot collide with legitimate keys in the repository.
+ -
+ - This is accomplished by appending a special extension to the key,
+ - that is not one that selectExtension would select (due to being too
+ - long).
+ -}
+testKeyBackend :: Backend
+testKeyBackend = 
+	let b = genBackendE (SHAHash 256)
+	in b { getKey = (fmap addE) <$$> getKey b } 
+  where
+	addE k = k { keyName = keyName k ++ longext }
+	longext = ".this-is-a-test-key"

CmdLine/GitAnnex.hs

@@ -96,9 +96,10 @@ import qualified Command.XMPPGit
 #endif
 import qualified Command.RemoteDaemon
 #endif
-import qualified Command.Test
 #ifdef WITH_TESTSUITE
+import qualified Command.Test
 import qualified Command.FuzzTest
+import qualified Command.TestRemote
 #endif
 #ifdef WITH_EKG
 import System.Remote.Monitoring
@@ -187,9 +188,10 @@ cmds = concat
 #endif
 	, Command.RemoteDaemon.def
 #endif
-	, Command.Test.def
 #ifdef WITH_TESTSUITE
+	, Command.Test.def
 	, Command.FuzzTest.def
+	, Command.TestRemote.def
 #endif
 	]
 

Command/TestRemote.hs

@@ -0,0 +1,125 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.TestRemote where
+
+import Common
+import Command
+import qualified Annex
+import qualified Remote
+import Types
+import Types.Key (key2file, keyBackendName, keySize)
+import Types.Backend (getKey, fsckKey)
+import Types.KeySource
+import Annex.Content
+import Backend
+import qualified Backend.Hash
+import Utility.Tmp
+import Utility.Metered
+import Messages
+import Types.Messages
+
+import Test.Tasty
+import Test.Tasty.Runners
+import Test.Tasty.HUnit
+import "crypto-api" Crypto.Random
+import qualified Data.ByteString as B
+
+def :: [Command]
+def = [ command "testremote" paramRemote seek SectionTesting
+		"test transfers to/from a remote"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start ws = do
+	let name = unwords ws
+	showStart "testremote" name
+	r <- either error id <$> Remote.byName' name
+	showSideAction "generating test keys"
+	ks <- testKeys
+	next $ perform r ks
+
+perform :: Remote -> [Key] -> CommandPerform
+perform r ks = do
+	st <- Annex.getState id
+	let tests = testGroup "Remote Tests" $
+		map (\k -> testGroup (descSize k) (testList st r k)) ks
+	ok <- case tryIngredients [consoleTestReporter] mempty tests of
+		Nothing -> error "No tests found!?"
+		Just act -> liftIO act
+	next $ cleanup r ks ok
+  where
+	descSize k = "key size " ++ show (keySize k)
+
+testList :: Annex.AnnexState -> Remote -> Key -> [TestTree]
+testList st r k =
+	[ check "removeKey when not present" $
+		Remote.removeKey r k
+	, present False
+	, check "storeKey" $
+		Remote.storeKey r k Nothing nullMeterUpdate
+	, present True
+	, check "storeKey when already present" $
+		Remote.storeKey r k Nothing nullMeterUpdate
+	, present True
+	, check "retrieveKeyFile" $ do
+		removeAnnex k
+		getViaTmp k $ \dest ->
+			Remote.retrieveKeyFile r k Nothing dest nullMeterUpdate
+	, check "fsck downloaded object" $ do
+		case maybeLookupBackendName (keyBackendName k) of
+			Nothing -> return True
+			Just b -> case fsckKey b of
+				Nothing -> return True
+				Just fscker -> fscker k (key2file k)
+	, check "removeKey when present" $
+		Remote.removeKey r k
+	, present False
+	]
+  where
+	check desc a = testCase desc $
+		Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed"
+	present b = check ("present " ++ show b) $
+		(== Right b) <$> Remote.hasKey r k
+
+cleanup :: Remote -> [Key] -> Bool -> CommandCleanup
+cleanup r ks ok = do
+	forM_ ks (Remote.removeKey r)
+	forM_ ks removeAnnex
+	return ok
+
+-- Generate random keys of several interesting sizes, assuming a chunk
+-- size that is a uniform divisor of 1 MB.
+testKeys :: Annex [Key]
+testKeys = mapM randKey
+	[ 0 -- empty key is a special case when chunking
+	, mb
+	, mb + 1
+	, mb - 1
+	, mb + mb
+	]
+  where
+	mb = 1024 * 2014
+
+randKey :: Int -> Annex Key
+randKey sz = withTmpFile "randkey" $ \f h -> do
+	gen <- liftIO (newGenIO :: IO SystemRandom)
+	case genBytes sz gen of
+		Left e -> error $ "failed to generate random key: " ++ show e
+		Right (rand, _) -> liftIO $ B.hPut h rand
+	liftIO $ hClose h
+	let ks = KeySource
+		{ keyFilename = f
+		, contentLocation = f
+		, inodeCache = Nothing
+		}
+	k <- fromMaybe (error "failed to generate random key")
+		<$> getKey Backend.Hash.testKeyBackend ks
+	moveAnnex k f
+	return k

Utility/Metered.hs

@@ -24,6 +24,9 @@ import Data.Int
  - far, *not* an incremental amount since the last call. -}
 type MeterUpdate = (BytesProcessed -> IO ())
 
+nullMeterUpdate :: MeterUpdate
+nullMeterUpdate _ = return ()
+
 {- Total number of bytes processed so far. -}
 newtype BytesProcessed = BytesProcessed Integer
 	deriving (Eq, Ord, Show)

debian/changelog

@@ -15,7 +15,7 @@ git-annex (5.20140718) UNRELEASED; urgency=medium
     were incompletely repaired before.
   * Fix cost calculation for non-encrypted remotes.
   * WebDAV: Dropped support for DAV before 0.6.1.
-  * testremote: New command.
+  * testremote: New command to test uploads/downloads to a remote.
 
  -- Joey Hess <joeyh@debian.org>  Mon, 21 Jul 2014 14:41:26 -0400
 

doc/git-annex.mdwn

@@ -966,6 +966,14 @@ subdirectories).
   There are several parameters, provided by Haskell's tasty test framework.
   Pass --help for details.
 
+* `testremote remote`
+
+  This tests a remote by generating some random objects and sending them to
+  the remote, then redownloading them, removing them from the remote, etc.
+
+  It's safe to run in an existing repository (the repository contents are
+  not altered), although it may perform expensive data transfers.
+
 * `fuzztest`
 
   Generates random changes to files in the current repository,

git-annex.cabal

@@ -124,7 +124,7 @@ Executable git-annex
 
   if flag(TestSuite)
     Build-Depends: tasty (>= 0.7), tasty-hunit, tasty-quickcheck, tasty-rerun,
-     optparse-applicative
+     optparse-applicative, crypto-api
     CPP-Options: -DWITH_TESTSUITE
 
   if flag(TDFA)