From e19dc8554723a148e6b809da4989a747f3aa925e Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Fri, 2 Dec 2011 16:10:52 -0400
Subject: factor out untilTrue

---
 Remote/Git.hs          |  5 +----
 Remote/Rsync.hs        | 50 ++++++++++++++++++++------------------------------
 Remote/Web.hs          |  6 ++----
 Utility/Conditional.hs |  6 ++++++
 4 files changed, 29 insertions(+), 38 deletions(-)

diff --git a/Remote/Git.hs b/Remote/Git.hs
index 07afc0274..99ca9fe8e 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -200,10 +200,7 @@ copyFromRemote r key file
 	| Git.repoIsHttp r = liftIO $ downloadurls $ keyUrls r key
 	| otherwise = error "copying from non-ssh, non-http repo not supported"
 	where
-		downloadurls [] = return False
-		downloadurls (u:us) = do
-			ok <- Url.download u file
-			if ok then return ok else downloadurls us
+		downloadurls us = untilTrue us $ \u -> Url.download u file
 
 {- Tries to copy a key's content to a remote's annex. -}
 copyToRemote :: Git.Repo -> Key -> Annex Bool
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 651ed4de8..81107cb56 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -97,16 +97,6 @@ rsyncUrlDirs o k = map use annexHashes
 	where
 		use h = rsyncUrl o </> h k </> rsyncEscape o (keyFile k)
 
-withRsyncUrl :: RsyncOpts -> Key -> (FilePath -> Annex Bool) -> Annex Bool
-withRsyncUrl o k a = go $ rsyncUrls o k
-	where
-		go [] = return False
-		go (u:us) = do
-			ok <- a u
-			if ok
-				then return ok
-				else go us
-
 store :: RsyncOpts -> Key -> Annex Bool
 store o k = rsyncSend o k =<< inRepo (gitAnnexLocation k)
 
@@ -117,12 +107,13 @@ storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do
 	rsyncSend o enck tmp
 
 retrieve :: RsyncOpts -> Key -> FilePath -> Annex Bool
-retrieve o k f = withRsyncUrl o k $ \u -> rsyncRemote o
-	-- use inplace when retrieving to support resuming
-	[ Param "--inplace"
-	, Param u
-	, Param f
-	]
+retrieve o k f = untilTrue (rsyncUrls o k) $ \u ->
+	rsyncRemote o
+		-- use inplace when retrieving to support resuming
+		[ Param "--inplace"
+		, Param u
+		, Param f
+		]
 
 retrieveEncrypted :: RsyncOpts -> (Cipher, Key) -> FilePath -> Annex Bool
 retrieveEncrypted o (cipher, enck) f = withTmp enck $ \tmp -> do
@@ -134,19 +125,18 @@ retrieveEncrypted o (cipher, enck) f = withTmp enck $ \tmp -> do
 		else return res
 
 remove :: RsyncOpts -> Key -> Annex Bool
-remove o k = any (== True) <$> sequence (map go (rsyncUrlDirs o k))
-	where
-		go d = withRsyncScratchDir $ \tmp -> liftIO $ do
-			{- Send an empty directory to rysnc as the
-			 - parent directory of the file to remove. -}
-			let dummy = tmp </> keyFile k
-			createDirectoryIfMissing True dummy
-			rsync $ rsyncOptions o ++
-				[ Params "--quiet --delete --recursive"
-				, partialParams
-				, Param $ addTrailingPathSeparator dummy
-				, Param d
-				]
+remove o k = untilTrue (rsyncUrlDirs o k) $ \d ->
+	withRsyncScratchDir $ \tmp -> liftIO $ do
+		{- Send an empty directory to rysnc as the
+		 - parent directory of the file to remove. -}
+		let dummy = tmp </> keyFile k
+		createDirectoryIfMissing True dummy
+		rsync $ rsyncOptions o ++
+			[ Params "--quiet --delete --recursive"
+			, partialParams
+			, Param $ addTrailingPathSeparator dummy
+			, Param d
+			]
 
 checkPresent :: Git.Repo -> RsyncOpts -> Key -> Annex (Either String Bool)
 checkPresent r o k = do
@@ -155,7 +145,7 @@ checkPresent r o k = do
 	-- to connect, and the file not being present.
 	Right <$> check
 	where
- 		check = withRsyncUrl o k $ \u ->
+ 		check = untilTrue (rsyncUrls o k) $ \u ->
 			liftIO $ boolSystem "sh" [Param "-c", Param (cmd u)]
 		cmd u = "rsync --quiet " ++ shellEscape u ++ " 2>/dev/null"
 
diff --git a/Remote/Web.hs b/Remote/Web.hs
index 64fcd51aa..5871ae8da 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -71,8 +71,6 @@ checkKey key = do
 		then return $ Right False
 		else return . Right =<< checkKey' us
 checkKey' :: [URLString] -> Annex Bool
-checkKey' [] = return False
-checkKey' (u:us) = do
+checkKey' us = untilTrue us $ \u -> do
 	showAction $ "checking " ++ u
-	e <- liftIO $ Url.exists u
-	if e then return e else checkKey' us
+	liftIO $ Url.exists u
diff --git a/Utility/Conditional.hs b/Utility/Conditional.hs
index 85e39ec64..7a0df4b48 100644
--- a/Utility/Conditional.hs
+++ b/Utility/Conditional.hs
@@ -9,6 +9,12 @@ module Utility.Conditional where
 
 import Control.Monad (when, unless)
 
+untilTrue :: Monad m => [v] -> (v -> m Bool) -> m Bool
+untilTrue [] _ = return False
+untilTrue (v:vs) a = do
+	ok <- a v
+	if ok then return ok else untilTrue vs a
+
 whenM :: Monad m => m Bool -> m () -> m ()
 whenM c a = c >>= flip when a
 
-- 
cgit v1.2.3