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
		Add a link
		
	
		Reference in a new issue
	
	 Joey Hess
				Joey Hess