diff options
| -rw-r--r-- | Remote.hs | 3 | ||||
| -rw-r--r-- | Remote/Directory.hs | 36 | ||||
| -rw-r--r-- | Remote/Git.hs | 36 | ||||
| -rw-r--r-- | Remote/S3real.hs | 66 | ||||
| -rw-r--r-- | Remote/Special.hs | 43 | ||||
| -rw-r--r-- | RemoteClass.hs | 6 |
6 files changed, 90 insertions, 100 deletions
@@ -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 |