move supportedBackends list into annex monad

This was necessary so the File backend could import Backend w/o a cycle.

Moved code that checks whether enough backends have a file into File
backend.

Annex.hs

@@ -7,6 +7,8 @@ module Annex (
 	gitRepoChange,
 	backends,
 	backendsChange,
+	supportedBackends,
+	supportedBackendsChange,
 	flagIsSet,
 	flagChange,
 	Flag(..)
@@ -20,20 +22,21 @@ import qualified BackendTypes as Backend
 
 {- Create and returns an Annex state object for the specified git repo.
  -}
-new :: Git.Repo -> IO AnnexState
-new g = do
+new :: Git.Repo -> [Backend] -> IO AnnexState
+new gitrepo allbackends = do
 	let s = Backend.AnnexState {
-		Backend.repo = g,
+		Backend.repo = gitrepo,
 		Backend.backends = [],
+		Backend.supportedBackends = allbackends,
 		Backend.flags = []
 	}
-	(_,s') <- Annex.run s (prep g)
+	(_,s') <- Annex.run s (prep gitrepo)
 	return s'
 	where
-		prep g = do
+		prep gitrepo = do
 			-- read git config and update state
-			g' <- liftIO $ Git.configRead g
-			Annex.gitRepoChange g'
+			gitrepo' <- liftIO $ Git.configRead gitrepo
+			Annex.gitRepoChange gitrepo'
 
 -- performs an action in the Annex monad
 run state action = runStateT (action) state
@@ -57,6 +60,15 @@ backendsChange b = do
 	state <- get
 	put state { Backend.backends = b }
 	return ()
+supportedBackends :: Annex [Backend]
+supportedBackends = do
+	state <- get
+	return (Backend.supportedBackends state)
+supportedBackendsChange :: [Backend] -> Annex ()
+supportedBackendsChange b = do
+	state <- get
+	put state { Backend.supportedBackends = b }
+	return ()
 flagIsSet :: Flag -> Annex Bool
 flagIsSet flag = do
 	state <- get

Backend.hs

@@ -28,14 +28,12 @@ import System.FilePath
 import Data.String.Utils
 import System.Posix.Files
 
-import BackendList
 import Locations
 import qualified GitRepo as Git
 import qualified Annex
 import Utility
 import Types
 import qualified BackendTypes as B
-import BackendList
 
 {- List of backends in the order to try them when storing a new key. -}
 backendList :: Annex [Backend]
@@ -44,10 +42,24 @@ backendList = do
 	if (0 < length l)
 		then return l
 		else do
+			all <- Annex.supportedBackends
 			g <- Annex.gitRepo
-			let l = parseBackendList $ Git.configGet g "annex.backends" ""
+			let l = parseBackendList all $ Git.configGet g "annex.backends" ""
 			Annex.backendsChange l
 			return l
+	where
+		parseBackendList all s = 
+			if (length s == 0)
+				then all
+				else map (lookupBackendName all) $ words s
+
+{- Looks up a backend in the list of supportedBackends -}
+lookupBackendName :: [Backend] -> String -> Backend
+lookupBackendName all s =
+	if ((length matches) /= 1)
+		then error $ "unknown backend " ++ s
+		else matches !! 0
+	where matches = filter (\b -> s == B.name b) all
 
 {- Attempts to store a file in one of the backends. -}
 storeFileKey :: FilePath -> Annex (Maybe (Key, Backend))
@@ -81,21 +93,24 @@ removeKey backend key = (B.removeKey backend)  key
 
 {- Checks if a backend has its key. -}
 hasKey :: Key -> Annex Bool
-hasKey key = (B.hasKey (lookupBackendName $ backendName key)) key
+hasKey key = do
+	all <- Annex.supportedBackends
+	(B.hasKey (lookupBackendName all $ backendName key)) key
 
 {- Looks up the key and backend corresponding to an annexed file,
  - by examining what the file symlinks to. -}
-lookupFile :: FilePath -> IO (Maybe (Key, Backend))
+lookupFile :: FilePath -> Annex (Maybe (Key, Backend))
 lookupFile file = do
-	result <- try (lookup)::IO (Either SomeException (Maybe (Key, Backend)))
+	all <- Annex.supportedBackends
+	result <- liftIO $ (try (lookup all)::IO (Either SomeException (Maybe (Key, Backend))))
 	case (result) of
 		Left err -> return Nothing
 		Right succ -> return succ
 	where 
-		lookup = do
+		lookup all = do
 			l <- readSymbolicLink file
-			return $ Just $ pair $ takeFileName l
-		pair file = (k, b)
+			return $ Just $ pair all $ takeFileName l
+		pair all file = (k, b)
 			where
 				k = fileKey file
-				b = lookupBackendName $ backendName k
+				b = lookupBackendName all $ backendName k

Backend/File.hs

@@ -25,13 +25,14 @@ import Utility
 import Core
 import qualified Annex
 import UUID
+import qualified Backend
 
 backend = Backend {
 	name = mustProvide,
 	getKey = mustProvide,
 	storeFileKey = dummyStore,
 	retrieveKeyFile = copyKeyFile,
-	removeKey = dummyRemove,
+	removeKey = checkRemoveKey,
 	hasKey = checkKeyFile
 }
 
@@ -41,10 +42,6 @@ mustProvide = error "must provide this field"
 dummyStore :: FilePath -> Key -> Annex (Bool)
 dummyStore file key = return True
 
-{- Allow keys to be removed. -}
-dummyRemove :: Key -> Annex Bool
-dummyRemove url = return True
-
 {- Just check if the .git/annex/ file for the key exists. -}
 checkKeyFile :: Key -> Annex Bool
 checkKeyFile k = inAnnex k
@@ -102,3 +99,56 @@ copyFromRemote r key file = do
 				else error "cp failed"
 		getremote = error "get via network not yet implemented!"
 		location = annexLocation r key
+
+{- Checks remotes to verify that enough copies of a key exist to allow
+ - for a key to be safely removed (with no data loss), and fails with an
+ - error if not. -}
+checkRemoveKey :: Key -> Annex (Bool)
+checkRemoveKey key = do
+	force <- Annex.flagIsSet Force
+	if (force)
+		then return True
+		else do
+			g <- Annex.gitRepo
+			let numcopies = read $ Git.configGet g config "1"
+			remotes <- Remotes.withKey key
+			if (numcopies > length remotes)
+				then retNotEnoughCopiesKnown remotes numcopies
+				else findcopies numcopies remotes []
+	where
+		failMsg w = do
+			liftIO $ hPutStrLn stderr $ "git-annex: " ++ w
+			return False -- failure, not enough copies found
+		findcopies 0 _ _ = return True -- success, enough copies found
+		findcopies _ [] bad = notEnoughCopiesSeen bad
+		findcopies n (r:rs) bad = do
+			all <- Annex.supportedBackends
+			result <- liftIO $ ((try $ remoteHasKey r all)::IO (Either SomeException Bool))
+			case (result) of
+				Right True	-> findcopies (n-1) rs bad
+				Right False	-> findcopies n rs bad
+				Left _		-> findcopies n rs (r:bad)
+		remoteHasKey r all = do
+			-- To check if a remote has a key, construct a new
+			-- Annex monad and query its backend.
+			a <- Annex.new r all
+			(result, _) <- Annex.run a (Backend.hasKey key)
+			return result
+		notEnoughCopiesSeen bad = failMsg $
+				"I failed to find enough other copies of: " ++
+				(keyFile key) ++
+				(if (0 /= length bad) then listbad bad else "")
+				++ unsafe
+		listbad bad = "\nI was unable to access these remotes: " ++
+				(Remotes.list bad) 
+		retNotEnoughCopiesKnown remotes numcopies = failMsg $ 
+				"I only know about " ++ (show $ length remotes) ++ 
+				" out of " ++ (show numcopies) ++ 
+				" necessary copies of: " ++ (keyFile key) ++
+				unsafe
+		unsafe = "\n" ++
+			"  -- According to the " ++ config ++
+			" setting, it is not safe to remove it!\n" ++
+			"     (Use --force to override.)"
+
+		config = "annex.numcopies"

BackendList.hs

@@ -1,11 +1,7 @@
 {- git-annex backend list
  - -}
 
-module BackendList (
-	supportedBackends,
-	parseBackendList,
-	lookupBackendName
-) where
+module BackendList (allBackends) where
 
 import BackendTypes
 
@@ -13,25 +9,8 @@ import BackendTypes
 import qualified Backend.WORM
 import qualified Backend.SHA1
 import qualified Backend.URL
-supportedBackends = 
+allBackends = 
 	[ Backend.WORM.backend
 	, Backend.SHA1.backend
 	, Backend.URL.backend
 	]
-
-{- Parses a string with a list of backend names into
- - a list of Backend objects. If the list is empty,
- - defaults to supportedBackends. -}
-parseBackendList :: String -> [Backend]
-parseBackendList s = 
-	if (length s == 0)
-		then supportedBackends
-		else map (lookupBackendName) $ words s
-
-{- Looks up a supported backend by name. -}
-lookupBackendName :: String -> Backend
-lookupBackendName s =
-	if ((length matches) /= 1)
-		then error $ "unknown backend " ++ s
-		else matches !! 0
-	where matches = filter (\b -> s == name b) supportedBackends

BackendTypes.hs

@@ -19,6 +19,7 @@ data Flag = Force | NoCommit | NeedCommit
 data AnnexState = AnnexState {
 	repo :: Git.Repo,
 	backends :: [Backend],
+	supportedBackends :: [Backend],
 	flags :: [Flag]
 } deriving (Show)
 

Commands.hs

@@ -16,7 +16,6 @@ import qualified Annex
 import Utility
 import Locations
 import qualified Backend
-import BackendList
 import UUID
 import LocationLog
 import Types
@@ -169,10 +168,6 @@ dropCmd file = notinBackend file err $ \(key, backend) -> do
 	if (not inbackend)
 		then return () -- no-op
 		else do
-			force <- Annex.flagIsSet Force
-			if (not force)
-				then requireEnoughCopies key
-				else return ()
 			success <- Backend.removeKey backend key
 			if (success)
 				then cleanup key
@@ -235,51 +230,8 @@ logStatus key status = do
 	gitAdd f Nothing -- all logs are committed at end
 
 inBackend file yes no = do
-	r <- liftIO $ Backend.lookupFile file
+	r <- Backend.lookupFile file
 	case (r) of
 		Just v -> yes v
 		Nothing -> no
 notinBackend file yes no = inBackend file no yes
-
-{- Checks remotes to verify that enough copies of a key exist to allow
- - for a key to be safely removed (with no data loss), and fails with an
- - error if not. -}
-requireEnoughCopies :: Key -> Annex ()
-requireEnoughCopies key = do
-	g <- Annex.gitRepo
-	let numcopies = read $ Git.configGet g config "1"
-	remotes <- Remotes.withKey key
-	if (numcopies > length remotes)
-		then error $ "I only know about " ++ (show $ length remotes) ++ 
-			" out of " ++ (show numcopies) ++ 
-			" necessary copies of: " ++ (keyFile key) ++
-			unsafe
-		else findcopies numcopies remotes []
-	where
-		findcopies 0 _ _ = return () -- success, enough copies found
-		findcopies _ [] bad = die bad
-		findcopies n (r:rs) bad = do
-			result <- liftIO $ try $ haskey r
-			case (result) of
-				Right True	-> findcopies (n-1) rs bad
-				Right False	-> findcopies n rs bad
-				Left _		-> findcopies n rs (r:bad)
-		haskey r = do
-			-- To check if a remote has a key, construct a new
-			-- Annex monad and query its backend.
-			a <- Annex.new r
-			(result, _) <- Annex.run a (Backend.hasKey key)
-			return result
-		die bad =
-			error $ "I failed to find enough other copies of: " ++
-				(keyFile key) ++
-				(if (0 /= length bad) then listbad bad else "")
-				++ unsafe
-		listbad bad = "\nI was unable to access these remotes: " ++
-				(Remotes.list bad) 
-		unsafe = "\n" ++
-			"  -- According to the " ++ config ++
-			" setting, it is not safe to remove it!\n" ++
-			"     (Use --force to override.)"
-
-		config = "annex.numcopies"

git-annex.hs

@@ -9,11 +9,12 @@ import Types
 import Core
 import Commands
 import qualified GitRepo as Git
+import BackendList
 
 main = do
 	args <- getArgs
 	gitrepo <- Git.repoFromCwd
-	state <- Annex.new gitrepo
+	state <- Annex.new gitrepo allBackends
 	(flags, actions) <- parseCmd args state
 	tryRun state $ [startup flags] ++ actions ++ [shutdown]