diff options
| -rw-r--r-- | Remote.hs | 24 | ||||
| -rw-r--r-- | Remote/Git.hs | 41 | ||||
| -rw-r--r-- | Remote/S3.hs | 55 | ||||
| -rw-r--r-- | RemoteClass.hs | 7 |
4 files changed, 60 insertions, 67 deletions
@@ -59,11 +59,19 @@ genList = do rs <- Annex.getState Annex.remotes if null rs then do - l <- mapM generator remoteTypes - rs' <- getConfigs (concat l) + m <- readRemoteLog + l <- mapM (process m) remoteTypes + let rs' = concat l Annex.changeState $ \s -> s { Annex.remotes = rs' } return rs' else return rs + where + process m t = do + l <- enumerate t + mapM (gen m t) l + gen m t r = do + u <- getUUID r + generate t r (M.lookup u m) {- Looks up a remote by name. (Or by UUID.) -} byName :: String -> Annex (Remote Annex) @@ -122,18 +130,6 @@ remoteLog = do g <- Annex.gitRepo return $ gitStateDir g ++ "remote.log" -{- Load stored config into remotes. - - - - This way, the log is read once, lazily, so if no remotes access - - their config, no work is done. - -} -getConfigs :: [Remote Annex] -> Annex [Remote Annex] -getConfigs rs = do - m <- readRemoteLog - return $ map (get m) rs - where - get m r = r { config = M.lookup (uuid r) m } - {- Adds or updates a remote's config in the log. -} configSet :: UUID -> M.Map String String -> Annex () configSet u c = do diff --git a/Remote/Git.hs b/Remote/Git.hs index e5f2aa62d..984f9c88f 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -14,9 +14,7 @@ import Control.Exception.Extensible import Control.Monad.State (liftIO) import qualified Data.Map as M import System.Cmd.Utils -import Control.Monad (filterM, liftM, when) -import Data.String.Utils -import Maybe +import Control.Monad (filterM) import RemoteClass import Types @@ -35,40 +33,35 @@ import Config remote :: RemoteType Annex remote = RemoteType { typename = "git", - generator = gen, + enumerate = list, + generate = gen, setup = error "not supported" } -gen :: Annex [Remote Annex] -gen = do +list :: Annex [Git.Repo] +list = do g <- Annex.gitRepo - allremotes <- filterM remoteNotIgnored $ Git.remotes g + filterM remoteNotIgnored $ Git.remotes g +gen :: Git.Repo -> Maybe (M.Map String String) -> Annex (Remote Annex) +gen repo _ = 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 = filter (not . Git.repoIsUrl) allremotes - let expensive = filter Git.repoIsUrl allremotes - expensive_todo <- filterM noCachedUUID expensive - let skip = filter (`notElem` expensive_todo) expensive - let todo = cheap++expensive_todo - - when (not $ null expensive_todo) $ - showNote $ "getting UUID for " ++ (join ", " $ - map Git.repoDescribe expensive_todo) - done <- mapM tryGitConfigRead todo - - generated <- mapM genRemote $ skip ++ done - return $ catMaybes generated - where - noCachedUUID r = liftM null $ getUUID r + 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 (Maybe (Remote Annex)) +genRemote :: Git.Repo -> Annex (Remote Annex) genRemote r = do u <- getUUID r c <- remoteCost r - return $ Just $ Remote { + return $ Remote { uuid = u, cost = c, name = Git.repoDescribe r, diff --git a/Remote/S3.hs b/Remote/S3.hs index 887b19e73..4e151e22f 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -28,20 +28,20 @@ import UUID import Config import Utility import Messages +import Locations remote :: RemoteType Annex remote = RemoteType { typename = "S3", - generator = gen, + enumerate = s3List, + generate = s3Gen, setup = s3Setup } -gen :: Annex [Remote Annex] -gen = do +s3List :: Annex [Git.Repo] +s3List = do g <- Annex.gitRepo - l <- filterM remoteNotIgnored $ findS3Remotes g - generated <- mapM genRemote l - return $ catMaybes generated + filterM remoteNotIgnored $ findS3Remotes g {- S3 remotes have a remote.<name>.annex-s3 config setting. - Git.Repo does not normally generate remotes for things that @@ -55,28 +55,27 @@ findS3Remotes r = map construct remotepairs construct (k,_) = Git.repoRemoteNameSet Git.repoFromUnknown k s3remote k = startswith "remote." k && endswith ".annex-s3" k -genRemote :: Git.Repo -> Annex (Maybe (Remote Annex)) -genRemote r = do +s3Gen :: Git.Repo -> Maybe (M.Map String String) -> Annex (Remote Annex) +s3Gen r c = do u <- getUUID r - if (u == "") - then return Nothing - else do - c <- remoteCost r - return $ Just $ newremote u c + cst <- remoteCost r + return $ genRemote r u c cst where - newremote u c = this - where - this = Remote { - uuid = u, - cost = c, - name = Git.repoDescribe r, - storeKey = s3Store this, - retrieveKeyFile = error "TODO retrievekey", - removeKey = error "TODO removekey", - hasKey = s3CheckPresent this, - hasKeyCheap = False, - config = Nothing - } + +genRemote :: Git.Repo -> UUID -> Maybe (M.Map String String) -> Int -> Remote Annex +genRemote r u c cst = this + where + this = Remote { + uuid = u, + cost = cst, + name = Git.repoDescribe r, + storeKey = s3Store this, + retrieveKeyFile = error "TODO retrievekey", + removeKey = error "TODO removekey", + hasKey = s3CheckPresent this, + hasKeyCheap = False, + config = c + } s3Connection :: M.Map String String -> IO AWSConnection s3Connection c = do @@ -155,8 +154,10 @@ s3CheckPresent r k = s3Action r $ \(conn, bucket) -> do s3Store :: Remote Annex -> Key -> Annex Bool s3Store r k = s3Action r $ \(conn, bucket) -> do + g <- Annex.gitRepo + content <- liftIO $ L.readFile $ gitAnnexLocation g k let object = setStorageClass storageclass $ - S3Object bucket (s3File k) "" [] (error "read content here") + S3Object bucket (s3File k) "" [] content res <- liftIO $ sendObject conn object case res of Right _ -> return True diff --git a/RemoteClass.hs b/RemoteClass.hs index e16cbdbb0..de4c281f4 100644 --- a/RemoteClass.hs +++ b/RemoteClass.hs @@ -12,14 +12,17 @@ module RemoteClass where import Control.Exception import Data.Map as M +import qualified GitRepo as Git import Key {- There are different types of remotes. -} data RemoteType a = RemoteType { -- human visible type name typename :: String, - -- generates remotes of this type - generator :: a [Remote a], + -- 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), -- initializes or changes a remote setup :: String -> M.Map String String -> a (M.Map String String) } |