added export remote tests

This commit is contained in:
Joey Hess 2020-04-30 13:13:08 -04:00
parent 735d2e90df
commit fc1ae62ef1
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
2 changed files with 17 additions and 15 deletions

View file

@ -89,7 +89,7 @@ start o = starting "testremote" (ActionItemOther (Just (testRemote o))) $ do
then return [r'] then return [r']
else remoteVariants r' basesz fast else remoteVariants r' basesz fast
unavailr <- Remote.mkUnavailable r' unavailr <- Remote.mkUnavailable r'
exportr <- if Remote.readonly r' let exportr = if Remote.readonly r'
then return Nothing then return Nothing
else exportTreeVariant r' else exportTreeVariant r'
perform rs unavailr exportr ks perform rs unavailr exportr ks
@ -101,14 +101,14 @@ remoteVariants r basesz fast = do
rs <- catMaybes <$> mapM (adjustChunkSize r) (chunkSizes basesz fast) rs <- catMaybes <$> mapM (adjustChunkSize r) (chunkSizes basesz fast)
concat <$> mapM encryptionVariants rs concat <$> mapM encryptionVariants rs
perform :: [Remote] -> Maybe Remote -> Maybe Remote -> [Key] -> CommandPerform perform :: [Remote] -> Maybe Remote -> Annex (Maybe Remote) -> [Key] -> CommandPerform
perform rs unavailr exportr ks = do perform rs unavailr exportr ks = do
st <- liftIO . newTVarIO =<< Annex.getState id st <- liftIO . newTVarIO =<< Annex.getState id
let tests = testGroup "Remote Tests" $ mkTestTrees let tests = testGroup "Remote Tests" $ mkTestTrees
(runTestCase st) (runTestCase st)
(map (\r -> Described (descr r) (pure r)) rs) (map (\r -> Described (descr r) (pure r)) rs)
(pure unavailr) (pure unavailr)
(fmap pure exportr) exportr
(map (\k -> Described (desck k) (pure k)) ks) (map (\k -> Described (desck k) (pure k)) ks)
ok <- case tryIngredients [consoleTestReporter] mempty tests of ok <- case tryIngredients [consoleTestReporter] mempty tests of
Nothing -> error "No tests found!?" Nothing -> error "No tests found!?"
@ -184,7 +184,7 @@ mkTestTrees
:: RunAnnex :: RunAnnex
-> [Described (Annex Remote)] -> [Described (Annex Remote)]
-> Annex (Maybe Remote) -> Annex (Maybe Remote)
-> Maybe (Annex Remote) -> Annex (Maybe Remote)
-> [Described (Annex Key)] -> [Described (Annex Key)]
-> [TestTree] -> [TestTree]
mkTestTrees runannex mkrs mkunavailr mkexportr mkks = concat $ mkTestTrees runannex mkrs mkunavailr mkexportr mkks = concat $
@ -270,9 +270,8 @@ test runannex mkr mkk =
store r k = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate store r k = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate
remove r k = Remote.removeKey r k remove r k = Remote.removeKey r k
testExportTree :: RunAnnex -> Maybe (Annex Remote) -> Annex Key -> Annex Key -> [TestTree] testExportTree :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> Annex Key -> [TestTree]
testExportTree _ Nothing _ _ = [] testExportTree runannex mkr mkk1 mkk2 =
testExportTree runannex (Just mkr) mkk1 mkk2 =
[ check "check present export when not present" $ \ea k1 _k2 -> [ check "check present export when not present" $ \ea k1 _k2 ->
not <$> checkpresentexport ea k1 not <$> checkpresentexport ea k1
, check "remove export when not present" $ \ea k1 _k2 -> , check "remove export when not present" $ \ea k1 _k2 ->
@ -307,11 +306,13 @@ testExportTree runannex (Just mkr) mkk1 mkk2 =
testexportdirectory = "testremote-export" testexportdirectory = "testremote-export"
testexportlocation = mkExportLocation (toRawFilePath (testexportdirectory </> "location")) testexportlocation = mkExportLocation (toRawFilePath (testexportdirectory </> "location"))
check desc a = testCase desc $ do check desc a = testCase desc $ do
let a' = do let a' = mkr >>= \case
ea <- Remote.exportActions <$> mkr Just r -> do
k1 <- mkk1 let ea = Remote.exportActions r
k2 <- mkk2 k1 <- mkk1
a ea k1 k2 k2 <- mkk2
a ea k1 k2
Nothing -> return True
runannex a' @? "failed" runannex a' @? "failed"
storeexport ea k = do storeexport ea k = do
loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)

View file

@ -216,6 +216,7 @@ testRemote = withResource newEmptyTMVarIO (const noop) $ \getv ->
where where
reponame = "test repo" reponame = "test repo"
remotename = "dir" remotename = "dir"
remotetype =" directory"
basesz = 1024 * 1024 basesz = 1024 * 1024
keysizes = Command.TestRemote.keySizes basesz False keysizes = Command.TestRemote.keySizes basesz False
prep getv = do prep getv = do
@ -227,7 +228,7 @@ testRemote = withResource newEmptyTMVarIO (const noop) $ \getv ->
createDirectory "remotedir" createDirectory "remotedir"
git_annex "initremote" git_annex "initremote"
[ remotename [ remotename
, "type=directory" , "type=" ++ remotetype
, "directory=remotedir" , "directory=remotedir"
, "encryption=none" , "encryption=none"
, "--quiet" , "--quiet"
@ -244,9 +245,9 @@ testRemote = withResource newEmptyTMVarIO (const noop) $ \getv ->
go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr mkks go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr mkks
where where
runannex = inmainrepo . annexeval runannex = inmainrepo . annexeval
mkrs = [descas "remote" (fst <$> v)] mkrs = [descas (remotetype ++ " remote") (fst <$> v)]
mkunavailr = fst . snd <$> v mkunavailr = fst . snd <$> v
mkexportr = Nothing -- fst . snd . snd <$> v mkexportr = fst . snd . snd <$> v
mkks = map (\(sz, n) -> desckeysize sz (getk n)) mkks = map (\(sz, n) -> desckeysize sz (getk n))
(zip keysizes [0..]) (zip keysizes [0..])
getk n = fmap (!! n) (snd . snd . snd <$> v) getk n = fmap (!! n) (snd . snd . snd <$> v)