aebcc395ff
This fixed one bug where it needed to be and wasn't (in Assistant.Unused). And also found one place where lockContent was used unnecessarily (by drop --from remote). A few other places like uninit probably don't really need to lockContent, but it doesn't hurt to do call it anyway. This commit was sponsored by David Wagner.
228 lines
6.7 KiB
Haskell
228 lines
6.7 KiB
Haskell
{- 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 qualified Types.Remote as 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 Utility.DataUnits
|
|
import Utility.CopyFile
|
|
import Messages
|
|
import Types.Messages
|
|
import Remote.Helper.Chunked
|
|
import Locations
|
|
|
|
import Test.Tasty
|
|
import Test.Tasty.Runners
|
|
import Test.Tasty.HUnit
|
|
import "crypto-api" Crypto.Random
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.ByteString.Lazy as L
|
|
import qualified Data.Map as M
|
|
|
|
def :: [Command]
|
|
def = [ withOptions [sizeOption] $
|
|
command "testremote" paramRemote seek SectionTesting
|
|
"test transfers to/from a remote"]
|
|
|
|
sizeOption :: Option
|
|
sizeOption = fieldOption [] "size" paramSize "base key size (default 1MiB)"
|
|
|
|
seek :: CommandSeek
|
|
seek ps = do
|
|
basesz <- fromInteger . fromMaybe (1024 * 1024)
|
|
<$> getOptionField sizeOption (pure . getsize)
|
|
withWords (start basesz) ps
|
|
where
|
|
getsize v = v >>= readSize dataUnits
|
|
|
|
start :: Int -> [String] -> CommandStart
|
|
start basesz ws = do
|
|
let name = unwords ws
|
|
showStart "testremote" name
|
|
r <- either error id <$> Remote.byName' name
|
|
showSideAction "generating test keys"
|
|
fast <- Annex.getState Annex.fast
|
|
ks <- mapM randKey (keySizes basesz fast)
|
|
rs <- catMaybes <$> mapM (adjustChunkSize r) (chunkSizes basesz fast)
|
|
rs' <- concat <$> mapM encryptionVariants rs
|
|
unavailrs <- catMaybes <$> mapM Remote.mkUnavailable [r]
|
|
next $ perform rs' unavailrs ks
|
|
|
|
perform :: [Remote] -> [Remote] -> [Key] -> CommandPerform
|
|
perform rs unavailrs ks = do
|
|
st <- Annex.getState id
|
|
let tests = testGroup "Remote Tests" $ concat
|
|
[ [ testGroup "unavailable remote" (testUnavailable st r (Prelude.head ks)) | r <- unavailrs ]
|
|
, [ testGroup (desc r k) (test st r k) | k <- ks, r <- rs ]
|
|
]
|
|
ok <- case tryIngredients [consoleTestReporter] mempty tests of
|
|
Nothing -> error "No tests found!?"
|
|
Just act -> liftIO act
|
|
next $ cleanup rs ks ok
|
|
where
|
|
desc r' k = intercalate "; " $ map unwords
|
|
[ [ "key size", show (keySize k) ]
|
|
, [ show (getChunkConfig (Remote.config r')) ]
|
|
, ["encryption", fromMaybe "none" (M.lookup "encryption" (Remote.config r'))]
|
|
]
|
|
|
|
adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote)
|
|
adjustChunkSize r chunksize = adjustRemoteConfig r
|
|
(M.insert "chunk" (show chunksize))
|
|
|
|
-- Variants of a remote with no encryption, and with simple shared
|
|
-- encryption. Gpg key based encryption is not tested.
|
|
encryptionVariants :: Remote -> Annex [Remote]
|
|
encryptionVariants r = do
|
|
noenc <- adjustRemoteConfig r (M.insert "encryption" "none")
|
|
sharedenc <- adjustRemoteConfig r $
|
|
M.insert "encryption" "shared" .
|
|
M.insert "highRandomQuality" "false"
|
|
return $ catMaybes [noenc, sharedenc]
|
|
|
|
-- Regenerate a remote with a modified config.
|
|
adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote)
|
|
adjustRemoteConfig r adjustconfig = Remote.generate (Remote.remotetype r)
|
|
(Remote.repo r)
|
|
(Remote.uuid r)
|
|
(adjustconfig (Remote.config r))
|
|
(Remote.gitconfig r)
|
|
|
|
test :: Annex.AnnexState -> Remote -> Key -> [TestTree]
|
|
test st r k =
|
|
[ check "removeKey when not present" remove
|
|
, present False
|
|
, check "storeKey" store
|
|
, present True
|
|
, check "storeKey when already present" store
|
|
, present True
|
|
, check "retrieveKeyFile" $ do
|
|
lockContent k removeAnnex
|
|
get
|
|
, check "fsck downloaded object" fsck
|
|
, check "retrieveKeyFile resume from 33%" $ do
|
|
loc <- Annex.calcRepo (gitAnnexLocation k)
|
|
tmp <- prepTmp k
|
|
partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do
|
|
sz <- hFileSize h
|
|
L.hGet h $ fromInteger $ sz `div` 3
|
|
liftIO $ L.writeFile tmp partial
|
|
lockContent k removeAnnex
|
|
get
|
|
, check "fsck downloaded object" fsck
|
|
, check "retrieveKeyFile resume from 0" $ do
|
|
tmp <- prepTmp k
|
|
liftIO $ writeFile tmp ""
|
|
lockContent k removeAnnex
|
|
get
|
|
, check "fsck downloaded object" fsck
|
|
, check "retrieveKeyFile resume from end" $ do
|
|
loc <- Annex.calcRepo (gitAnnexLocation k)
|
|
tmp <- prepTmp k
|
|
void $ liftIO $ copyFileExternal loc tmp
|
|
lockContent k removeAnnex
|
|
get
|
|
, check "fsck downloaded object" fsck
|
|
, check "removeKey when present" remove
|
|
, 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
|
|
fsck = case maybeLookupBackendName (keyBackendName k) of
|
|
Nothing -> return True
|
|
Just b -> case fsckKey b of
|
|
Nothing -> return True
|
|
Just fscker -> fscker k (key2file k)
|
|
get = getViaTmp k $ \dest ->
|
|
Remote.retrieveKeyFile r k Nothing dest nullMeterUpdate
|
|
store = Remote.storeKey r k Nothing nullMeterUpdate
|
|
remove = Remote.removeKey r k
|
|
|
|
testUnavailable :: Annex.AnnexState -> Remote -> Key -> [TestTree]
|
|
testUnavailable st r k =
|
|
[ check (== Right False) "removeKey" $
|
|
Remote.removeKey r k
|
|
, check (== Right False) "storeKey" $
|
|
Remote.storeKey r k Nothing nullMeterUpdate
|
|
, check (`notElem` [Right True, Right False]) "checkPresent" $
|
|
Remote.checkPresent r k
|
|
, check (== Right False) "retrieveKeyFile" $
|
|
getViaTmp k $ \dest ->
|
|
Remote.retrieveKeyFile r k Nothing dest nullMeterUpdate
|
|
, check (== Right False) "retrieveKeyFileCheap" $
|
|
getViaTmp k $ \dest ->
|
|
Remote.retrieveKeyFileCheap r k dest
|
|
]
|
|
where
|
|
check checkval desc a = testCase desc $ do
|
|
v <- Annex.eval st $ do
|
|
Annex.setOutput QuietOutput
|
|
either (Left . show) Right <$> tryNonAsync a
|
|
checkval v @? ("(got: " ++ show v ++ ")")
|
|
|
|
cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup
|
|
cleanup rs ks ok = do
|
|
forM_ rs $ \r -> forM_ ks (Remote.removeKey r)
|
|
forM_ ks $ \k -> lockContent k removeAnnex
|
|
return ok
|
|
|
|
chunkSizes :: Int -> Bool -> [Int]
|
|
chunkSizes base False =
|
|
[ 0 -- no chunking
|
|
, base `div` 100
|
|
, base `div` 1000
|
|
, base
|
|
]
|
|
chunkSizes _ True =
|
|
[ 0
|
|
]
|
|
|
|
keySizes :: Int -> Bool -> [Int]
|
|
keySizes base fast = filter want
|
|
[ 0 -- empty key is a special case when chunking
|
|
, base
|
|
, base + 1
|
|
, base - 1
|
|
, base * 2
|
|
]
|
|
where
|
|
want sz
|
|
| fast = sz <= base && sz > 0
|
|
| otherwise = sz > 0
|
|
|
|
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
|