update
This commit is contained in:
parent
b1db436816
commit
a3b6586902
4 changed files with 45 additions and 19 deletions
19
Remote.hs
19
Remote.hs
|
@ -44,17 +44,16 @@ import LocationLog
|
||||||
import Locations
|
import Locations
|
||||||
import Messages
|
import Messages
|
||||||
|
|
||||||
{- Add generators for new Remotes here. -}
|
remoteTypes :: [RemoteType Annex]
|
||||||
generators :: [Annex (RemoteGenerator Annex)]
|
remoteTypes =
|
||||||
generators =
|
[ Remote.Git.remote
|
||||||
[ Remote.Git.generate
|
, Remote.S3.remote
|
||||||
, Remote.S3.generate
|
|
||||||
]
|
]
|
||||||
|
|
||||||
{- Runs a list of generators. -}
|
{- Runs the generators of each type of Remote -}
|
||||||
runGenerators :: [Annex (RemoteGenerator Annex)] -> Annex [Remote Annex]
|
runGenerators :: Annex [Remote Annex]
|
||||||
runGenerators gs = do
|
runGenerators = do
|
||||||
(actions, expensive) <- collect ([], []) gs
|
(actions, expensive) <- collect ([], []) $ map generator remoteTypes
|
||||||
when (not $ null expensive) $
|
when (not $ null expensive) $
|
||||||
showNote $ "getting UUID for " ++ join ", " expensive
|
showNote $ "getting UUID for " ++ join ", " expensive
|
||||||
sequence actions
|
sequence actions
|
||||||
|
@ -71,7 +70,7 @@ genList = do
|
||||||
rs <- Annex.getState Annex.remotes
|
rs <- Annex.getState Annex.remotes
|
||||||
if null rs
|
if null rs
|
||||||
then do
|
then do
|
||||||
rs' <- runGenerators generators
|
rs' <- runGenerators
|
||||||
Annex.changeState $ \s -> s { Annex.remotes = rs' }
|
Annex.changeState $ \s -> s { Annex.remotes = rs' }
|
||||||
return rs'
|
return rs'
|
||||||
else return rs
|
else return rs
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Remote.Git (
|
module Remote.Git (
|
||||||
generate,
|
remote,
|
||||||
onRemote
|
onRemote
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
@ -30,8 +30,11 @@ import RsyncFile
|
||||||
import Ssh
|
import Ssh
|
||||||
import Config
|
import Config
|
||||||
|
|
||||||
generate :: Annex (RemoteGenerator Annex)
|
remote :: RemoteType Annex
|
||||||
generate = do
|
remote = RemoteType { typename = "git", generator = gen }
|
||||||
|
|
||||||
|
gen :: Annex (RemoteGenerator Annex)
|
||||||
|
gen = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
allremotes <- filterM remoteNotIgnored $ Git.remotes g
|
allremotes <- filterM remoteNotIgnored $ Git.remotes g
|
||||||
|
|
||||||
|
@ -64,7 +67,10 @@ genRemote r = do
|
||||||
retrieveKeyFile = copyFromRemote r,
|
retrieveKeyFile = copyFromRemote r,
|
||||||
removeKey = dropKey r,
|
removeKey = dropKey r,
|
||||||
hasKey = inAnnex r,
|
hasKey = inAnnex r,
|
||||||
hasKeyCheap = not (Git.repoIsUrl r)
|
hasKeyCheap = not (Git.repoIsUrl r),
|
||||||
|
hasConfig = False,
|
||||||
|
config = Nothing,
|
||||||
|
setup = \_ -> return ()
|
||||||
}
|
}
|
||||||
|
|
||||||
{- Tries to read the config for a specified remote, updates state, and
|
{- Tries to read the config for a specified remote, updates state, and
|
||||||
|
|
14
Remote/S3.hs
14
Remote/S3.hs
|
@ -5,7 +5,7 @@
|
||||||
- Licensed under the GNU GPL version 3 or higher.
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Remote.S3 (generate) where
|
module Remote.S3 (remote) where
|
||||||
|
|
||||||
import Network.AWS.AWSConnection
|
import Network.AWS.AWSConnection
|
||||||
import Network.AWS.S3Object
|
import Network.AWS.S3Object
|
||||||
|
@ -27,8 +27,11 @@ import qualified Annex
|
||||||
import UUID
|
import UUID
|
||||||
import Config
|
import Config
|
||||||
|
|
||||||
generate :: Annex (RemoteGenerator Annex)
|
remote :: RemoteType Annex
|
||||||
generate = do
|
remote = RemoteType { typename = "S3", generator = gen }
|
||||||
|
|
||||||
|
gen :: Annex (RemoteGenerator Annex)
|
||||||
|
gen = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
remotes <- filterM remoteNotIgnored $ findS3Remotes g
|
remotes <- filterM remoteNotIgnored $ findS3Remotes g
|
||||||
todo <- filterM cachedUUID remotes
|
todo <- filterM cachedUUID remotes
|
||||||
|
@ -64,7 +67,10 @@ genRemote r u = do
|
||||||
retrieveKeyFile = error "TODO",
|
retrieveKeyFile = error "TODO",
|
||||||
removeKey = error "TODO",
|
removeKey = error "TODO",
|
||||||
hasKey = error "TODO",
|
hasKey = error "TODO",
|
||||||
hasKeyCheap = False
|
hasKeyCheap = False,
|
||||||
|
hasConfig = True,
|
||||||
|
config = Nothing,
|
||||||
|
setup = \_ -> return ()
|
||||||
}
|
}
|
||||||
|
|
||||||
s3Connection :: Git.Repo -> Annex (Maybe AWSConnection)
|
s3Connection :: Git.Repo -> Annex (Maybe AWSConnection)
|
||||||
|
|
|
@ -10,6 +10,7 @@
|
||||||
module RemoteClass where
|
module RemoteClass where
|
||||||
|
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
|
import Data.Map as M
|
||||||
|
|
||||||
import Key
|
import Key
|
||||||
|
|
||||||
|
@ -18,6 +19,15 @@ import Key
|
||||||
- that are not cheap to set up. -}
|
- that are not cheap to set up. -}
|
||||||
type RemoteGenerator a = ([a (Remote a)], [String])
|
type RemoteGenerator a = ([a (Remote a)], [String])
|
||||||
|
|
||||||
|
{- There are different types of remotes. -}
|
||||||
|
data RemoteType a = RemoteType {
|
||||||
|
-- human visible type name
|
||||||
|
typename :: String,
|
||||||
|
-- generates remotes of this type
|
||||||
|
generator :: a (RemoteGenerator a)
|
||||||
|
}
|
||||||
|
|
||||||
|
{- An individual remote. -}
|
||||||
data Remote a = Remote {
|
data Remote a = Remote {
|
||||||
-- each Remote has a unique uuid
|
-- each Remote has a unique uuid
|
||||||
uuid :: String,
|
uuid :: String,
|
||||||
|
@ -36,7 +46,12 @@ data Remote a = Remote {
|
||||||
hasKey :: Key -> a (Either IOException Bool),
|
hasKey :: Key -> a (Either IOException Bool),
|
||||||
-- Some remotes can check hasKey without an expensive network
|
-- Some remotes can check hasKey without an expensive network
|
||||||
-- operation.
|
-- operation.
|
||||||
hasKeyCheap :: Bool
|
hasKeyCheap :: Bool,
|
||||||
|
-- a Remote may have a persistent configuration store
|
||||||
|
hasConfig :: Bool,
|
||||||
|
config :: Maybe (M.Map String String),
|
||||||
|
-- initializes or changes the config of a remote
|
||||||
|
setup :: M.Map String String -> a ()
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Show (Remote a) where
|
instance Show (Remote a) where
|
||||||
|
|
Loading…
Reference in a new issue