mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

RemoteConfig type

Browse source
This commit is contained in:
Joey Hess 2011-04-15 15:09:36 -04:00
parent f7018e47e4
commit 1e84dab4c8
8 changed files with 33 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
Command/InitRemote.hs
View file

@ -44,14 +44,14 @@ start params = notBareRepo $ do
where where
ws = words params ws = words params
name = head ws name = head ws
config = Remote.keyValToMap $ tail ws config = Remote.keyValToConfig $ tail ws
perform :: RemoteClass.RemoteType Annex -> UUID -> M.Map String String -> CommandPerform perform :: RemoteClass.RemoteType Annex -> UUID -> RemoteClass.RemoteConfig -> CommandPerform
perform t u c = do perform t u c = do
c' <- RemoteClass.setup t u c c' <- RemoteClass.setup t u c
return $ Just $ cleanup u c' return $ Just $ cleanup u c'
cleanup :: UUID -> M.Map String String -> CommandCleanup cleanup :: UUID -> RemoteClass.RemoteConfig -> CommandCleanup
cleanup u c = do cleanup u c = do
Remote.configSet u c Remote.configSet u c
g <- Annex.gitRepo g <- Annex.gitRepo
@ -65,7 +65,7 @@ cleanup u c = do
return True return True
{- Look up existing remote's UUID and config by name, or generate a new one -} {- Look up existing remote's UUID and config by name, or generate a new one -}
findByName :: String -> Annex (UUID, M.Map String String) findByName :: String -> Annex (UUID, RemoteClass.RemoteConfig)
findByName name = do findByName name = do
m <- Remote.readRemoteLog m <- Remote.readRemoteLog
case findByName' name m of case findByName' name m of
@ -74,7 +74,7 @@ findByName name = do
uuid <- liftIO $ genUUID uuid <- liftIO $ genUUID
return $ (uuid, M.insert nameKey name M.empty) return $ (uuid, M.insert nameKey name M.empty)
findByName' :: String -> M.Map UUID (M.Map String String) -> Maybe (UUID, M.Map String String) findByName' :: String -> M.Map UUID RemoteClass.RemoteConfig -> Maybe (UUID, RemoteClass.RemoteConfig)
findByName' n m = if null matches then Nothing else Just $ head matches findByName' n m = if null matches then Nothing else Just $ head matches
where where
matches = filter (matching . snd) $ M.toList m matches = filter (matching . snd) $ M.toList m
@ -85,7 +85,7 @@ findByName' n m = if null matches then Nothing else Just $ head matches
| otherwise -> False | otherwise -> False
{- find the specified remote type -} {- find the specified remote type -}
findType :: M.Map String String -> Annex (RemoteClass.RemoteType Annex) findType :: RemoteClass.RemoteConfig -> Annex (RemoteClass.RemoteType Annex)
findType config = findType config =
case M.lookup typeKey config of case M.lookup typeKey config of
Nothing -> error "Specify the type of remote with type=" Nothing -> error "Specify the type of remote with type="

22
Remote.hs
View file

@ -25,7 +25,7 @@ module Remote (
remoteLog, remoteLog,
readRemoteLog, readRemoteLog,
configSet, configSet,
keyValToMap keyValToConfig
) where ) where
import Control.Monad.State (liftIO) import Control.Monad.State (liftIO)
@ -137,17 +137,17 @@ remoteLog = do
return $ gitStateDir g ++ "remote.log" return $ gitStateDir g ++ "remote.log"
{- Adds or updates a remote's config in the log. -} {- Adds or updates a remote's config in the log. -}
configSet :: UUID -> M.Map String String -> Annex () configSet :: UUID -> RemoteConfig -> Annex ()
configSet u c = do configSet u c = do
m <- readRemoteLog m <- readRemoteLog
l <- remoteLog l <- remoteLog
liftIO $ safeWriteFile l $ unlines $ sort $ liftIO $ safeWriteFile l $ unlines $ sort $
map toline $ M.toList $ M.insert u c m map toline $ M.toList $ M.insert u c m
where where
toline (u', c') = u' ++ " " ++ (unwords $ mapToKeyVal c') toline (u', c') = u' ++ " " ++ (unwords $ configToKeyVal c')
{- Map of remotes by uuid containing key/value config maps. -} {- Map of remotes by uuid containing key/value config maps. -}
readRemoteLog :: Annex (M.Map UUID (M.Map String String)) readRemoteLog :: Annex (M.Map UUID RemoteConfig)
readRemoteLog = do readRemoteLog = do
l <- remoteLog l <- remoteLog
s <- liftIO $ catch (readFile l) ignoreerror s <- liftIO $ catch (readFile l) ignoreerror
@ -155,7 +155,7 @@ readRemoteLog = do
where where
ignoreerror _ = return "" ignoreerror _ = return ""
remoteLogParse :: String -> M.Map UUID (M.Map String String) remoteLogParse :: String -> M.Map UUID RemoteConfig
remoteLogParse s = remoteLogParse s =
M.fromList $ catMaybes $ map parseline $ filter (not . null) $ lines s M.fromList $ catMaybes $ map parseline $ filter (not . null) $ lines s
where where
@ -165,18 +165,18 @@ remoteLogParse s =
where where
w = words l w = words l
u = w !! 0 u = w !! 0
c = keyValToMap $ tail w c = keyValToConfig $ tail w
{- Given Strings like "key=value", generates a Map. -} {- Given Strings like "key=value", generates a RemoteConfig. -}
keyValToMap :: [String] -> M.Map String String keyValToConfig :: [String] -> RemoteConfig
keyValToMap ws = M.fromList $ map (/=/) ws keyValToConfig ws = M.fromList $ map (/=/) ws
where where
(/=/) s = (k, v) (/=/) s = (k, v)
where where
k = takeWhile (/= '=') s k = takeWhile (/= '=') s
v = drop (1 + length k) s v = drop (1 + length k) s
mapToKeyVal :: M.Map String String -> [String] configToKeyVal :: M.Map String String -> [String]
mapToKeyVal m = map toword $ sort $ M.toList m configToKeyVal m = map toword $ sort $ M.toList m
where where
toword (k, v) = k ++ "=" ++ v toword (k, v) = k ++ "=" ++ v

4
Remote/Bup.hs
View file

@ -39,7 +39,7 @@ remote = RemoteType {
setup = bupSetup setup = bupSetup
} }
gen :: Git.Repo -> UUID -> Maybe (M.Map String String) -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
gen r u c = do gen r u c = do
buprepo <- getConfig r "buprepo" (error "missing buprepo") buprepo <- getConfig r "buprepo" (error "missing buprepo")
cst <- remoteCost r (if bupLocal buprepo then semiCheapRemoteCost else expensiveRemoteCost) cst <- remoteCost r (if bupLocal buprepo then semiCheapRemoteCost else expensiveRemoteCost)
@ -60,7 +60,7 @@ gen r u c = do
config = c config = c
} }
bupSetup :: UUID -> M.Map String String -> Annex (M.Map String String) bupSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
bupSetup u c = do bupSetup u c = do
-- verify configuration is sane -- verify configuration is sane
let buprepo = case M.lookup "buprepo" c of let buprepo = case M.lookup "buprepo" c of

4
Remote/Directory.hs
View file

@ -35,7 +35,7 @@ remote = RemoteType {
setup = directorySetup setup = directorySetup
} }
gen :: Git.Repo -> UUID -> Maybe (M.Map String String) -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
gen r u _ = do gen r u _ = do
dir <- getConfig r "directory" (error "missing directory") dir <- getConfig r "directory" (error "missing directory")
cst <- remoteCost r cheapRemoteCost cst <- remoteCost r cheapRemoteCost
@ -51,7 +51,7 @@ gen r u _ = do
config = Nothing config = Nothing
} }
directorySetup :: UUID -> M.Map String String -> Annex (M.Map String String) directorySetup :: UUID -> RemoteConfig -> Annex RemoteConfig
directorySetup u c = do directorySetup u c = do
-- verify configuration is sane -- verify configuration is sane
let dir = case M.lookup "directory" c of let dir = case M.lookup "directory" c of

2
Remote/Git.hs
View file

@ -40,7 +40,7 @@ list = do
g <- Annex.gitRepo g <- Annex.gitRepo
return $ Git.remotes g return $ Git.remotes g
gen :: Git.Repo -> UUID -> Maybe (M.Map String String) -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
gen r u _ = do gen r u _ = do
{- It's assumed to be cheap to read the config of non-URL remotes, {- 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, - so this is done each time git-annex is run. Conversely,

8
Remote/S3real.hs
View file

@ -37,7 +37,7 @@ remote = RemoteType {
setup = s3Setup setup = s3Setup
} }
gen :: Git.Repo -> UUID -> Maybe (M.Map String String) -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
gen r u c = do gen r u c = do
cst <- remoteCost r expensiveRemoteCost cst <- remoteCost r expensiveRemoteCost
return $ this cst return $ this cst
@ -54,14 +54,14 @@ gen r u c = do
config = c config = c
} }
s3ConnectionRequired :: M.Map String String -> Annex AWSConnection s3ConnectionRequired :: RemoteConfig -> Annex AWSConnection
s3ConnectionRequired c = do s3ConnectionRequired c = do
conn <- s3Connection c conn <- s3Connection c
case conn of case conn of
Nothing -> error "Cannot connect to S3" Nothing -> error "Cannot connect to S3"
Just conn' -> return conn' Just conn' -> return conn'
s3Connection :: M.Map String String -> Annex (Maybe AWSConnection) s3Connection :: RemoteConfig -> Annex (Maybe AWSConnection)
s3Connection c = do s3Connection c = do
ak <- getEnvKey "AWS_ACCESS_KEY_ID" ak <- getEnvKey "AWS_ACCESS_KEY_ID"
sk <- getEnvKey "AWS_SECRET_ACCESS_KEY" sk <- getEnvKey "AWS_SECRET_ACCESS_KEY"
@ -78,7 +78,7 @@ s3Connection c = do
_ -> error $ "bad S3 port value: " ++ s _ -> error $ "bad S3 port value: " ++ s
getEnvKey s = liftIO $ catch (getEnv s) (const $ return "") getEnvKey s = liftIO $ catch (getEnv s) (const $ return "")
s3Setup :: UUID -> M.Map String String -> Annex (M.Map String String) s3Setup :: UUID -> RemoteConfig -> Annex RemoteConfig
s3Setup u c = do s3Setup u c = do
-- verify configuration is sane -- verify configuration is sane
case M.lookup "encryption" c of case M.lookup "encryption" c of

3
Remote/Special.hs
View file

@ -13,6 +13,7 @@ import Data.String.Utils
import Control.Monad.State (liftIO) import Control.Monad.State (liftIO)
import Types import Types
import RemoteClass
import qualified GitRepo as Git import qualified GitRepo as Git
import qualified Annex import qualified Annex
import UUID import UUID
@ -32,7 +33,7 @@ findSpecialRemotes s = do
match k _ = startswith "remote." k && endswith (".annex-"++s) k match k _ = startswith "remote." k && endswith (".annex-"++s) k
{- Sets up configuration for a special remote in .git/config. -} {- Sets up configuration for a special remote in .git/config. -}
gitConfigSpecialRemote :: UUID -> M.Map String String -> String -> String -> Annex () gitConfigSpecialRemote :: UUID -> RemoteConfig -> String -> String -> Annex ()
gitConfigSpecialRemote u c k v = do gitConfigSpecialRemote u c k v = do
g <- Annex.gitRepo g <- Annex.gitRepo
liftIO $ do liftIO $ do

8
RemoteClass.hs
View file

@ -15,6 +15,8 @@ import Data.Map as M
import qualified GitRepo as Git import qualified GitRepo as Git
import Key import Key
type RemoteConfig = M.Map String String
{- There are different types of remotes. -} {- There are different types of remotes. -}
data RemoteType a = RemoteType { data RemoteType a = RemoteType {
-- human visible type name -- human visible type name
@ -22,9 +24,9 @@ data RemoteType a = RemoteType {
-- enumerates remotes of this type -- enumerates remotes of this type
enumerate :: a [Git.Repo], enumerate :: a [Git.Repo],
-- generates a remote of this type -- generates a remote of this type
generate :: Git.Repo -> String -> Maybe (M.Map String String) -> a (Remote a), generate :: Git.Repo -> String -> Maybe RemoteConfig -> a (Remote a),
-- initializes or changes a remote -- initializes or changes a remote
setup :: String -> M.Map String String -> a (M.Map String String) setup :: String -> RemoteConfig -> a RemoteConfig
} }
{- An individual remote. -} {- An individual remote. -}
@ -48,7 +50,7 @@ data Remote a = Remote {
-- operation. -- operation.
hasKeyCheap :: Bool, hasKeyCheap :: Bool,
-- a Remote can have a persistent configuration store -- a Remote can have a persistent configuration store
config :: Maybe (M.Map String String) config :: Maybe RemoteConfig
} }
instance Show (Remote a) where instance Show (Remote a) where