boilerplate reduction

Remote.hs

@@ -75,7 +75,8 @@ genList = do
 			mapM (gen m t) l'
 		gen m t r = do
 			u <- getUUID r
-			generate t r (M.lookup u m)
+			cst <- remoteCost r
+			generate t r u cst (M.lookup u m)
 
 {- Looks up a remote by name. (Or by UUID.) -}
 byName :: String -> Annex (Remote Annex)

Remote/Directory.hs

@@ -11,7 +11,6 @@ import IO
 import Control.Exception.Extensible (IOException)
 import qualified Data.Map as M
 import Data.Maybe
-import Data.String.Utils
 import Control.Monad (when)
 import Control.Monad.State (liftIO)
 import System.Directory (doesDirectoryExist, doesFileExist, removeFile)
@@ -22,41 +21,21 @@ import Types
 import qualified GitRepo as Git
 import qualified Annex
 import UUID
-import Config
 import Utility
 import Locations
 import CopyFile
+import Remote.Special
 
 remote :: RemoteType Annex
 remote = RemoteType {
 	typename = "directory",
-	enumerate = list,
+	enumerate = findSpecialRemotes "directory",
 	generate = gen,
-	setup = dosetup
+	setup = directorySetup
 }
 
-list :: Annex [Git.Repo]
-list = do
-	g <- Annex.gitRepo
-	return $ findDirectoryRemotes g
-
-findDirectoryRemotes :: Git.Repo -> [Git.Repo]
-findDirectoryRemotes r = map construct remotepairs
-	where
-		remotepairs = M.toList $ filterremotes $ Git.configMap r
-		filterremotes = M.filterWithKey (\k _ -> directoryremote k)
-		construct (k,_) = Git.repoRemoteNameSet Git.repoFromUnknown k
-		directoryremote k = startswith "remote." k && endswith ".annex-directory" k
-
-gen :: Git.Repo -> Maybe (M.Map String String) -> Annex (Remote Annex)
-gen r c = do
-	u <- getUUID r
-	cst <- remoteCost r
-	return $ genRemote r u c cst
-	where
-
-genRemote :: Git.Repo -> UUID -> Maybe (M.Map String String) -> Int -> Remote Annex
-genRemote r u c cst = this
+gen :: Git.Repo -> UUID -> Cost -> Maybe (M.Map String String) -> Annex (Remote Annex)
+gen r u cst c = return this
 	where
 		this = Remote {
 			uuid = u,
@@ -70,8 +49,8 @@ genRemote r u c cst = this
 			config = c
 		}
 
-dosetup :: UUID -> M.Map String String -> Annex (M.Map String String)
-dosetup u c = do
+directorySetup :: UUID -> M.Map String String -> Annex (M.Map String String)
+directorySetup u c = do
 	-- verify configuration is sane
 	let dir = case M.lookup "directory" c of
 		Nothing -> error "Specify directory="
@@ -79,6 +58,7 @@ dosetup u c = do
 	e <- liftIO $ doesDirectoryExist dir
 	when (not e) $ error $ "Directory does not exist: " ++ dir
 
+	gitConfigSpecialRemote "directory" u c
 	g <- Annex.gitRepo
 	liftIO $ do
 		Git.run g "config" [Param (configsetting "annex-directory"), Param "true"]

Remote/Git.hs

@@ -42,33 +42,27 @@ list = do
 	g <- Annex.gitRepo
 	return $ Git.remotes g
 
-gen :: Git.Repo -> Maybe (M.Map String String) -> Annex (Remote Annex)
-gen repo _ = do
+gen :: Git.Repo -> UUID -> Cost -> Maybe (M.Map String String) -> Annex (Remote Annex)
+gen r u cst _ = do
  	{- It's assumed to be cheap to read the config of non-URL remotes,
 	 - so this is done each time git-annex is run. Conversely,
 	 - the config of an URL remote is only read when there is no
 	 - cached UUID value. -}
-	let cheap = not $ Git.repoIsUrl repo
-	u <- getUUID repo
-	repo' <- case (cheap, u) of
-		(True, _) -> tryGitConfigRead repo
-		(False, "") -> tryGitConfigRead repo
-		_ -> return repo
-	genRemote repo'
-	
-genRemote :: Git.Repo -> Annex (Remote Annex)
-genRemote r = do
-	u <- getUUID r
-	c <- remoteCost r
+	let cheap = not $ Git.repoIsUrl r
+	r' <- case (cheap, u) of
+		(True, _) -> tryGitConfigRead r
+		(False, "") -> tryGitConfigRead r
+		_ -> return r
+
 	return $ Remote {
 		uuid = u,
-		cost = c,
-		name = Git.repoDescribe r,
-		storeKey = copyToRemote r,
-		retrieveKeyFile = copyFromRemote r,
-		removeKey = dropKey r,
-		hasKey = inAnnex r,
-		hasKeyCheap = not (Git.repoIsUrl r),
+		cost = cst,
+		name = Git.repoDescribe r',
+		storeKey = copyToRemote r',
+		retrieveKeyFile = copyFromRemote r',
+		removeKey = dropKey r',
+		hasKey = inAnnex r',
+		hasKeyCheap = not (Git.repoIsUrl r'),
 		config = Nothing
 	}
 

Remote/S3real.hs

@@ -15,7 +15,6 @@ import Network.AWS.AWSResult
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Map as M
 import Data.Maybe
-import Data.String.Utils
 import Control.Monad (when)
 import Control.Monad.State (liftIO)
 import System.Environment
@@ -25,54 +24,29 @@ import Types
 import qualified GitRepo as Git
 import qualified Annex
 import UUID
-import Config
-import Utility
 import Messages
 import Locations
+import Remote.Special
 
 remote :: RemoteType Annex
 remote = RemoteType {
 	typename = "S3",
-	enumerate = s3List,
-	generate = s3Gen,
+	enumerate = findSpecialRemotes "s3",
+	generate = gen,
 	setup = s3Setup
 }
 
-s3List :: Annex [Git.Repo]
-s3List = do
-	g <- Annex.gitRepo
-	return $ findS3Remotes g
-
-{- S3 remotes have a remote.<name>.annex-s3 config setting.
- - Git.Repo does not normally generate remotes for things that
- - have no configured url, so the Git.Repo objects have to be
- - constructed as coming from an unknown location. -}
-findS3Remotes :: Git.Repo -> [Git.Repo]
-findS3Remotes r = map construct remotepairs
-	where
-		remotepairs = M.toList $ filterremotes $ Git.configMap r
-		filterremotes = M.filterWithKey (\k _ -> s3remote k)
-		construct (k,_) = Git.repoRemoteNameSet Git.repoFromUnknown k
-		s3remote k = startswith "remote." k && endswith ".annex-s3" k
-
-s3Gen :: Git.Repo -> Maybe (M.Map String String) -> Annex (Remote Annex)
-s3Gen r c = do
-	u <- getUUID r
-	cst <- remoteCost r
-	return $ genRemote r u c cst
-	where
-
-genRemote :: Git.Repo -> UUID -> Maybe (M.Map String String) -> Int -> Remote Annex
-genRemote r u c cst = this
+gen :: Git.Repo -> UUID -> Cost -> Maybe (M.Map String String) -> Annex (Remote Annex)
+gen r u cst c = return this
 	where
 		this = Remote {
 			uuid = u,
 			cost = cst,
 			name = Git.repoDescribe r,
-	 		storeKey = s3Store this,
-			retrieveKeyFile = s3Retrieve this,
-			removeKey = s3Remove this,
-			hasKey = s3CheckPresent this,
+	 		storeKey = store this,
+			retrieveKeyFile = retrieve this,
+			removeKey = remove this,
+			hasKey = checkPresent this,
 			hasKeyCheap = False,
 			config = c
 		}
@@ -114,15 +88,11 @@ s3Setup u c = do
 				Right _ -> return ()
 				Left err -> error $ prettyReqError err
 
-	g <- Annex.gitRepo
-	liftIO $ do
-		Git.run g "config" [Param (configsetting "annex-s3"), Param "true"]
-		Git.run g "config" [Param (configsetting "annex-uuid"), Param u]
+	gitConfigSpecialRemote "s3" u fullconfig
 	return fullconfig
 	where
 		remotename = fromJust (M.lookup "name" c)
 		bucket = remotename ++ "-" ++ u
-		configsetting s = "remote." ++ remotename ++ "." ++ s
 		defaults = M.fromList
 			[ ("datacenter", "US")
 			, ("storageclass", "STANDARD")
@@ -142,8 +112,8 @@ s3Action r a = do
 bucketKey :: String -> Key -> L.ByteString -> S3Object
 bucketKey bucket k content = S3Object bucket (show k) "" [] content
 
-s3CheckPresent :: Remote Annex -> Key -> Annex (Either IOException Bool)
-s3CheckPresent r k = s3Action r $ \(conn, bucket) -> do
+checkPresent :: Remote Annex -> Key -> Annex (Either IOException Bool)
+checkPresent r k = s3Action r $ \(conn, bucket) -> do
 	showNote ("checking " ++ name r ++ "...")
 	res <- liftIO $ getObjectInfo conn $ bucketKey bucket k L.empty
 	case res of
@@ -151,8 +121,8 @@ s3CheckPresent r k = s3Action r $ \(conn, bucket) -> do
 		Left (AWSError _ _) -> return $ Right False
 		Left e -> return $ Left (error $ prettyReqError e)
 
-s3Store :: Remote Annex -> Key -> Annex Bool
-s3Store r k = s3Action r $ \(conn, bucket) -> do
+store :: Remote Annex -> Key -> Annex Bool
+store r k = s3Action r $ \(conn, bucket) -> do
 	g <- Annex.gitRepo
 	content <- liftIO $ L.readFile $ gitAnnexLocation g k
 	let object = setStorageClass storageclass $ bucketKey bucket k content
@@ -168,8 +138,8 @@ s3Store r k = s3Action r $ \(conn, bucket) -> do
 				"REDUCED_REDUNDANCY" -> REDUCED_REDUNDANCY
 				_ -> STANDARD
 
-s3Retrieve :: Remote Annex -> Key -> FilePath -> Annex Bool
-s3Retrieve r k f = s3Action r $ \(conn, bucket) -> do
+retrieve :: Remote Annex -> Key -> FilePath -> Annex Bool
+retrieve r k f = s3Action r $ \(conn, bucket) -> do
 	res <- liftIO $ getObject conn $ bucketKey bucket k L.empty
 	case res of
 		Right o -> do
@@ -179,8 +149,8 @@ s3Retrieve r k f = s3Action r $ \(conn, bucket) -> do
 			warning $ prettyReqError e
 			return False
 
-s3Remove :: Remote Annex -> Key -> Annex Bool
-s3Remove r k = s3Action r $ \(conn, bucket) -> do
+remove :: Remote Annex -> Key -> Annex Bool
+remove r k = s3Action r $ \(conn, bucket) -> do
 	res <- liftIO $ deleteObject conn $ bucketKey bucket k L.empty
 	case res of
 		Right _ -> return True

Remote/Special.hs

@@ -0,0 +1,43 @@
+{- common functions for special remotes
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Special where
+
+import qualified Data.Map as M
+import Data.Maybe
+import Data.String.Utils
+import Control.Monad.State (liftIO)
+
+import Types
+import qualified GitRepo as Git
+import qualified Annex
+import UUID
+import Utility
+
+{- Special remotes don't have a configured url, so Git.Repo does not
+ - automatically generate remotes for them. This looks for a different
+ - configuration key instead.
+ -}
+findSpecialRemotes :: String -> Annex [Git.Repo]
+findSpecialRemotes s = do
+	g <- Annex.gitRepo
+	return $ map construct $ remotepairs g
+	where
+		remotepairs r = M.toList $ M.filterWithKey match $ Git.configMap r
+		construct (k,_) = Git.repoRemoteNameSet Git.repoFromUnknown k
+		match k _ = startswith "remote." k && endswith (".annex-"++s) k
+
+{- Sets up configuration for a special remote in .git/config. -}
+gitConfigSpecialRemote :: String -> UUID -> M.Map String String -> Annex ()
+gitConfigSpecialRemote s u c = do
+	g <- Annex.gitRepo
+	liftIO $ do
+		Git.run g "config" [Param (configsetting $ "annex-"++s), Param "true"]
+		Git.run g "config" [Param (configsetting $ "annex-uuid"), Param u]
+	where
+		remotename = fromJust (M.lookup "name" c)
+		configsetting v = "remote." ++ remotename ++ "." ++ v

RemoteClass.hs

@@ -15,6 +15,8 @@ import Data.Map as M
 import qualified GitRepo as Git
 import Key
 
+type Cost = Int
+
 {- There are different types of remotes. -}
 data RemoteType a = RemoteType {
 	-- human visible type name
@@ -22,7 +24,7 @@ data RemoteType a = RemoteType {
 	-- enumerates remotes of this type
 	enumerate :: a [Git.Repo],
 	-- generates a remote of this type
-	generate :: Git.Repo -> Maybe (M.Map String String) -> a (Remote a),
+	generate :: Git.Repo -> String -> Cost -> Maybe (M.Map String String) -> a (Remote a),
 	-- initializes or changes a remote
 	setup :: String -> M.Map String String -> a (M.Map String String)
 }
@@ -34,7 +36,7 @@ data Remote a = Remote {
 	-- each Remote has a human visible name
 	name :: String,
 	-- Remotes have a use cost; higher is more expensive
-	cost :: Int,
+	cost :: Cost,
 	-- Transfers a key to the remote.
 	storeKey :: Key -> a Bool,
 	-- retrieves a key's contents to a file