RemoteConfig type
This commit is contained in:
parent
f7018e47e4
commit
1e84dab4c8
8 changed files with 33 additions and 30 deletions
|
@ -44,14 +44,14 @@ start params = notBareRepo $ do
|
|||
where
|
||||
ws = words params
|
||||
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
|
||||
c' <- RemoteClass.setup t u c
|
||||
return $ Just $ cleanup u c'
|
||||
|
||||
cleanup :: UUID -> M.Map String String -> CommandCleanup
|
||||
cleanup :: UUID -> RemoteClass.RemoteConfig -> CommandCleanup
|
||||
cleanup u c = do
|
||||
Remote.configSet u c
|
||||
g <- Annex.gitRepo
|
||||
|
@ -65,7 +65,7 @@ cleanup u c = do
|
|||
return True
|
||||
|
||||
{- 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
|
||||
m <- Remote.readRemoteLog
|
||||
case findByName' name m of
|
||||
|
@ -74,7 +74,7 @@ findByName name = do
|
|||
uuid <- liftIO $ genUUID
|
||||
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
|
||||
where
|
||||
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
|
||||
|
||||
{- find the specified remote type -}
|
||||
findType :: M.Map String String -> Annex (RemoteClass.RemoteType Annex)
|
||||
findType :: RemoteClass.RemoteConfig -> Annex (RemoteClass.RemoteType Annex)
|
||||
findType config =
|
||||
case M.lookup typeKey config of
|
||||
Nothing -> error "Specify the type of remote with type="
|
||||
|
|
22
Remote.hs
22
Remote.hs
|
@ -25,7 +25,7 @@ module Remote (
|
|||
remoteLog,
|
||||
readRemoteLog,
|
||||
configSet,
|
||||
keyValToMap
|
||||
keyValToConfig
|
||||
) where
|
||||
|
||||
import Control.Monad.State (liftIO)
|
||||
|
@ -137,17 +137,17 @@ remoteLog = do
|
|||
return $ gitStateDir g ++ "remote.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
|
||||
m <- readRemoteLog
|
||||
l <- remoteLog
|
||||
liftIO $ safeWriteFile l $ unlines $ sort $
|
||||
map toline $ M.toList $ M.insert u c m
|
||||
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. -}
|
||||
readRemoteLog :: Annex (M.Map UUID (M.Map String String))
|
||||
readRemoteLog :: Annex (M.Map UUID RemoteConfig)
|
||||
readRemoteLog = do
|
||||
l <- remoteLog
|
||||
s <- liftIO $ catch (readFile l) ignoreerror
|
||||
|
@ -155,7 +155,7 @@ readRemoteLog = do
|
|||
where
|
||||
ignoreerror _ = return ""
|
||||
|
||||
remoteLogParse :: String -> M.Map UUID (M.Map String String)
|
||||
remoteLogParse :: String -> M.Map UUID RemoteConfig
|
||||
remoteLogParse s =
|
||||
M.fromList $ catMaybes $ map parseline $ filter (not . null) $ lines s
|
||||
where
|
||||
|
@ -165,18 +165,18 @@ remoteLogParse s =
|
|||
where
|
||||
w = words l
|
||||
u = w !! 0
|
||||
c = keyValToMap $ tail w
|
||||
c = keyValToConfig $ tail w
|
||||
|
||||
{- Given Strings like "key=value", generates a Map. -}
|
||||
keyValToMap :: [String] -> M.Map String String
|
||||
keyValToMap ws = M.fromList $ map (/=/) ws
|
||||
{- Given Strings like "key=value", generates a RemoteConfig. -}
|
||||
keyValToConfig :: [String] -> RemoteConfig
|
||||
keyValToConfig ws = M.fromList $ map (/=/) ws
|
||||
where
|
||||
(/=/) s = (k, v)
|
||||
where
|
||||
k = takeWhile (/= '=') s
|
||||
v = drop (1 + length k) s
|
||||
|
||||
mapToKeyVal :: M.Map String String -> [String]
|
||||
mapToKeyVal m = map toword $ sort $ M.toList m
|
||||
configToKeyVal :: M.Map String String -> [String]
|
||||
configToKeyVal m = map toword $ sort $ M.toList m
|
||||
where
|
||||
toword (k, v) = k ++ "=" ++ v
|
||||
|
|
|
@ -39,7 +39,7 @@ remote = RemoteType {
|
|||
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
|
||||
buprepo <- getConfig r "buprepo" (error "missing buprepo")
|
||||
cst <- remoteCost r (if bupLocal buprepo then semiCheapRemoteCost else expensiveRemoteCost)
|
||||
|
@ -60,7 +60,7 @@ gen r u c = do
|
|||
config = c
|
||||
}
|
||||
|
||||
bupSetup :: UUID -> M.Map String String -> Annex (M.Map String String)
|
||||
bupSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
|
||||
bupSetup u c = do
|
||||
-- verify configuration is sane
|
||||
let buprepo = case M.lookup "buprepo" c of
|
||||
|
|
|
@ -35,7 +35,7 @@ remote = RemoteType {
|
|||
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
|
||||
dir <- getConfig r "directory" (error "missing directory")
|
||||
cst <- remoteCost r cheapRemoteCost
|
||||
|
@ -51,7 +51,7 @@ gen r u _ = do
|
|||
config = Nothing
|
||||
}
|
||||
|
||||
directorySetup :: UUID -> M.Map String String -> Annex (M.Map String String)
|
||||
directorySetup :: UUID -> RemoteConfig -> Annex RemoteConfig
|
||||
directorySetup u c = do
|
||||
-- verify configuration is sane
|
||||
let dir = case M.lookup "directory" c of
|
||||
|
|
|
@ -40,7 +40,7 @@ list = do
|
|||
g <- Annex.gitRepo
|
||||
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
|
||||
{- 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,
|
||||
|
|
|
@ -37,7 +37,7 @@ remote = RemoteType {
|
|||
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
|
||||
cst <- remoteCost r expensiveRemoteCost
|
||||
return $ this cst
|
||||
|
@ -54,14 +54,14 @@ gen r u c = do
|
|||
config = c
|
||||
}
|
||||
|
||||
s3ConnectionRequired :: M.Map String String -> Annex AWSConnection
|
||||
s3ConnectionRequired :: RemoteConfig -> Annex AWSConnection
|
||||
s3ConnectionRequired c = do
|
||||
conn <- s3Connection c
|
||||
case conn of
|
||||
Nothing -> error "Cannot connect to S3"
|
||||
Just conn' -> return conn'
|
||||
|
||||
s3Connection :: M.Map String String -> Annex (Maybe AWSConnection)
|
||||
s3Connection :: RemoteConfig -> Annex (Maybe AWSConnection)
|
||||
s3Connection c = do
|
||||
ak <- getEnvKey "AWS_ACCESS_KEY_ID"
|
||||
sk <- getEnvKey "AWS_SECRET_ACCESS_KEY"
|
||||
|
@ -78,7 +78,7 @@ s3Connection c = do
|
|||
_ -> error $ "bad S3 port value: " ++ s
|
||||
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
|
||||
-- verify configuration is sane
|
||||
case M.lookup "encryption" c of
|
||||
|
|
|
@ -13,6 +13,7 @@ import Data.String.Utils
|
|||
import Control.Monad.State (liftIO)
|
||||
|
||||
import Types
|
||||
import RemoteClass
|
||||
import qualified GitRepo as Git
|
||||
import qualified Annex
|
||||
import UUID
|
||||
|
@ -32,7 +33,7 @@ findSpecialRemotes s = do
|
|||
match k _ = startswith "remote." k && endswith (".annex-"++s) k
|
||||
|
||||
{- 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
|
||||
g <- Annex.gitRepo
|
||||
liftIO $ do
|
||||
|
|
|
@ -15,6 +15,8 @@ import Data.Map as M
|
|||
import qualified GitRepo as Git
|
||||
import Key
|
||||
|
||||
type RemoteConfig = M.Map String String
|
||||
|
||||
{- There are different types of remotes. -}
|
||||
data RemoteType a = RemoteType {
|
||||
-- human visible type name
|
||||
|
@ -22,9 +24,9 @@ data RemoteType a = RemoteType {
|
|||
-- enumerates remotes of this type
|
||||
enumerate :: a [Git.Repo],
|
||||
-- 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
|
||||
setup :: String -> M.Map String String -> a (M.Map String String)
|
||||
setup :: String -> RemoteConfig -> a RemoteConfig
|
||||
}
|
||||
|
||||
{- An individual remote. -}
|
||||
|
@ -48,7 +50,7 @@ data Remote a = Remote {
|
|||
-- operation.
|
||||
hasKeyCheap :: Bool,
|
||||
-- a Remote can have a persistent configuration store
|
||||
config :: Maybe (M.Map String String)
|
||||
config :: Maybe RemoteConfig
|
||||
}
|
||||
|
||||
instance Show (Remote a) where
|
||||
|
|
Loading…
Reference in a new issue