diff --git a/Backend/Hash.hs b/Backend/Hash.hs index 91267ed67e..62d0a0fca5 100644 --- a/Backend/Hash.hs +++ b/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 = Just Backend +genBackend :: Hash -> Backend +genBackend hash = Backend { name = hashName hash , getKey = keyValue hash , fsckKey = Just $ checkKeyChecksum hash @@ -48,13 +51,11 @@ genBackend hash = Just Backend , isStableKey = const True } -genBackendE :: Hash -> Maybe Backend -genBackendE hash = do - b <- genBackend hash - return $ b - { name = hashNameE hash - , getKey = keyValueE hash - } +genBackendE :: Hash -> Backend +genBackendE hash = (genBackend hash) + { name = hashNameE hash + , getKey = keyValueE hash + } hashName :: Hash -> String hashName (SHAHash size) = "SHA" ++ show size @@ -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" diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 4c9377df9d..80a784dd77 100644 --- a/CmdLine/GitAnnex.hs +++ b/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 ] diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs new file mode 100644 index 0000000000..aedb8562d6 --- /dev/null +++ b/Command/TestRemote.hs @@ -0,0 +1,125 @@ +{- git-annex command + - + - Copyright 2014 Joey Hess + - + - 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 diff --git a/Utility/Metered.hs b/Utility/Metered.hs index cc07f9c351..4618aecfe4 100644 --- a/Utility/Metered.hs +++ b/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) diff --git a/debian/changelog b/debian/changelog index eb399dfee5..f8b700ae73 100644 --- a/debian/changelog +++ b/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 Mon, 21 Jul 2014 14:41:26 -0400 diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 9158b54e00..d618a619a5 100644 --- a/doc/git-annex.mdwn +++ b/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, diff --git a/git-annex.cabal b/git-annex.cabal index 0d0d979ea0..2a39489d40 100644 --- a/git-annex.cabal +++ b/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)