summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Remote.hs3
-rw-r--r--Remote/Directory.hs36
-rw-r--r--Remote/Git.hs36
-rw-r--r--Remote/S3real.hs66
-rw-r--r--Remote/Special.hs43
-rw-r--r--RemoteClass.hs6
6 files changed, 90 insertions, 100 deletions
diff --git a/Remote.hs b/Remote.hs
index 0cfec3c28..4e401ddcc 100644
--- a/Remote.hs
+++ b/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)
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 697de5ea7..12736e050 100644
--- a/Remote/Directory.hs
+++ b/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"]
diff --git a/Remote/Git.hs b/Remote/Git.hs
index d0dedd4fd..286a8c645 100644
--- a/Remote/Git.hs
+++ b/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
}
diff --git a/Remote/S3real.hs b/Remote/S3real.hs
index 260c1eee8..4380231fd 100644
--- a/Remote/S3real.hs
+++ b/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
diff --git a/Remote/Special.hs b/Remote/Special.hs
new file mode 100644
index 000000000..d985eef6f
--- /dev/null
+++ b/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
diff --git a/RemoteClass.hs b/RemoteClass.hs
index de4c281f4..43bf403de 100644
--- a/RemoteClass.hs
+++ b/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