added export remote tests
This commit is contained in:
parent
735d2e90df
commit
fc1ae62ef1
2 changed files with 17 additions and 15 deletions
|
@ -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)
|
||||||
|
|
7
Test.hs
7
Test.hs
|
@ -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)
|
||||||
|
|
Loading…
Add table
Reference in a new issue