copy --to S3 works

This commit is contained in:
Joey Hess 2011-03-29 17:57:20 -04:00
parent 72f94cc42e
commit 0782d70063
4 changed files with 60 additions and 67 deletions

View file

@ -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

View file

@ -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,

View file

@ -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

View file

@ -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)
}