copy --to S3 works
This commit is contained in:
parent
72f94cc42e
commit
0782d70063
4 changed files with 60 additions and 67 deletions
24
Remote.hs
24
Remote.hs
|
@ -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
|
||||
|
|
|
@ -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,
|
||||
|
|
55
Remote/S3.hs
55
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
|
||||
|
|
|
@ -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)
|
||||
}
|
||||
|
|
Loading…
Reference in a new issue