initremote works
This commit is contained in:
parent
05751d55cd
commit
0a4c610b4f
6 changed files with 85 additions and 30 deletions
|
@ -12,7 +12,12 @@ import Control.Monad (when)
|
||||||
import Control.Monad.State (liftIO)
|
import Control.Monad.State (liftIO)
|
||||||
|
|
||||||
import Command
|
import Command
|
||||||
|
import qualified Annex
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
|
import qualified RemoteClass
|
||||||
|
import qualified GitRepo as Git
|
||||||
|
import Utility
|
||||||
|
import Types
|
||||||
import UUID
|
import UUID
|
||||||
import Messages
|
import Messages
|
||||||
|
|
||||||
|
@ -28,27 +33,49 @@ seek = [withString start]
|
||||||
start :: CommandStartString
|
start :: CommandStartString
|
||||||
start params = notBareRepo $ do
|
start params = notBareRepo $ do
|
||||||
when (null ws) $ error "Specify a name for the remote"
|
when (null ws) $ error "Specify a name for the remote"
|
||||||
|
|
||||||
|
(u, c) <- findByName name
|
||||||
|
let fullconfig = M.union config c
|
||||||
|
t <- findType fullconfig
|
||||||
|
|
||||||
showStart "initremote" name
|
showStart "initremote" name
|
||||||
m <- Remote.readRemoteLog
|
return $ Just $ perform t u $ M.union config c
|
||||||
(u, c) <- case findByName name m of
|
|
||||||
Just t -> return t
|
|
||||||
Nothing -> do
|
|
||||||
uuid <- liftIO $ genUUID
|
|
||||||
return $ (uuid, M.insert nameKey name M.empty)
|
|
||||||
return $ Just $ perform name u $ M.union config c
|
|
||||||
|
|
||||||
where
|
where
|
||||||
ws = words params
|
ws = words params
|
||||||
name = head ws
|
name = head ws
|
||||||
config = Remote.keyValToMap $ tail ws
|
config = Remote.keyValToMap $ tail ws
|
||||||
|
|
||||||
perform :: String -> UUID -> M.Map String String -> CommandPerform
|
perform :: RemoteClass.RemoteType Annex -> UUID -> M.Map String String -> CommandPerform
|
||||||
perform name uuid config = do
|
perform t u c = do
|
||||||
liftIO $ putStrLn $ show $ (uuid, config)
|
c' <- RemoteClass.setup t u c
|
||||||
return Nothing
|
return $ Just $ cleanup u c'
|
||||||
|
|
||||||
findByName :: String -> M.Map UUID (M.Map String String) -> Maybe (UUID, M.Map String String)
|
cleanup :: UUID -> M.Map String String -> CommandCleanup
|
||||||
findByName n m = if null matches then Nothing else Just $ head matches
|
cleanup u c = do
|
||||||
|
Remote.configSet u c
|
||||||
|
g <- Annex.gitRepo
|
||||||
|
logfile <- Remote.remoteLog
|
||||||
|
liftIO $ Git.run g "add" [File logfile]
|
||||||
|
liftIO $ Git.run g "commit"
|
||||||
|
[ Params "-q --allow-empty -m"
|
||||||
|
, Param "git annex initremote"
|
||||||
|
, File logfile
|
||||||
|
]
|
||||||
|
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 name = do
|
||||||
|
m <- Remote.readRemoteLog
|
||||||
|
case findByName' name m of
|
||||||
|
Just i -> return i
|
||||||
|
Nothing -> 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' 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
|
||||||
matching c = case M.lookup nameKey c of
|
matching c = case M.lookup nameKey c of
|
||||||
|
@ -57,6 +84,19 @@ findByName n m = if null matches then Nothing else Just $ head matches
|
||||||
| n' == n -> True
|
| n' == n -> True
|
||||||
| otherwise -> False
|
| otherwise -> False
|
||||||
|
|
||||||
|
{- find the specified remote type -}
|
||||||
|
findType :: M.Map String String -> Annex (RemoteClass.RemoteType Annex)
|
||||||
|
findType config =
|
||||||
|
case M.lookup typeKey config of
|
||||||
|
Nothing -> error "Specify the type of remote with type="
|
||||||
|
Just s -> case filter (\i -> RemoteClass.typename i == s) Remote.remoteTypes of
|
||||||
|
[] -> error $ "Unknown remote type " ++ s
|
||||||
|
(t:_) -> return t
|
||||||
|
|
||||||
{- The name of a configured remote is stored in its config using this key. -}
|
{- The name of a configured remote is stored in its config using this key. -}
|
||||||
nameKey :: String
|
nameKey :: String
|
||||||
nameKey = "name"
|
nameKey = "name"
|
||||||
|
|
||||||
|
{- The type of a remote is stored in its config using this key. -}
|
||||||
|
typeKey :: String
|
||||||
|
typeKey = "type"
|
||||||
|
|
13
Remote.hs
13
Remote.hs
|
@ -15,12 +15,14 @@ module Remote (
|
||||||
hasKey,
|
hasKey,
|
||||||
hasKeyCheap,
|
hasKeyCheap,
|
||||||
|
|
||||||
|
remoteTypes,
|
||||||
byName,
|
byName,
|
||||||
nameToUUID,
|
nameToUUID,
|
||||||
keyPossibilities,
|
keyPossibilities,
|
||||||
remotesWithUUID,
|
remotesWithUUID,
|
||||||
remotesWithoutUUID,
|
remotesWithoutUUID,
|
||||||
|
|
||||||
|
remoteLog,
|
||||||
readRemoteLog,
|
readRemoteLog,
|
||||||
configSet,
|
configSet,
|
||||||
keyValToMap
|
keyValToMap
|
||||||
|
@ -34,8 +36,6 @@ import qualified Data.Map as M
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
|
||||||
import RemoteClass
|
import RemoteClass
|
||||||
import qualified Remote.Git
|
|
||||||
import qualified Remote.S3
|
|
||||||
import Types
|
import Types
|
||||||
import UUID
|
import UUID
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
|
@ -43,6 +43,10 @@ import Trust
|
||||||
import LocationLog
|
import LocationLog
|
||||||
import Locations
|
import Locations
|
||||||
import Messages
|
import Messages
|
||||||
|
import Utility
|
||||||
|
|
||||||
|
import qualified Remote.Git
|
||||||
|
import qualified Remote.S3
|
||||||
|
|
||||||
remoteTypes :: [RemoteType Annex]
|
remoteTypes :: [RemoteType Annex]
|
||||||
remoteTypes =
|
remoteTypes =
|
||||||
|
@ -150,7 +154,8 @@ configSet :: UUID -> M.Map String String -> Annex ()
|
||||||
configSet u c = do
|
configSet u c = do
|
||||||
m <- readRemoteLog
|
m <- readRemoteLog
|
||||||
l <- remoteLog
|
l <- remoteLog
|
||||||
liftIO $ writeFile l $ unlines $ map toline $ M.toList $ M.insert u c m
|
liftIO $ safeWriteFile l $ unlines $ sort $
|
||||||
|
map toline $ M.toList $ M.insert u c m
|
||||||
where
|
where
|
||||||
toline (u', c') = u' ++ " " ++ (unwords $ mapToKeyVal c')
|
toline (u', c') = u' ++ " " ++ (unwords $ mapToKeyVal c')
|
||||||
|
|
||||||
|
@ -185,6 +190,6 @@ keyValToMap ws = M.fromList $ map (/=/) ws
|
||||||
v = drop (1 + length k) s
|
v = drop (1 + length k) s
|
||||||
|
|
||||||
mapToKeyVal :: M.Map String String -> [String]
|
mapToKeyVal :: M.Map String String -> [String]
|
||||||
mapToKeyVal m = map toword $ M.toList m
|
mapToKeyVal m = map toword $ sort $ M.toList m
|
||||||
where
|
where
|
||||||
toword (k, v) = k ++ "=" ++ v
|
toword (k, v) = k ++ "=" ++ v
|
||||||
|
|
|
@ -31,7 +31,11 @@ import Ssh
|
||||||
import Config
|
import Config
|
||||||
|
|
||||||
remote :: RemoteType Annex
|
remote :: RemoteType Annex
|
||||||
remote = RemoteType { typename = "git", generator = gen }
|
remote = RemoteType {
|
||||||
|
typename = "git",
|
||||||
|
generator = gen,
|
||||||
|
setup = error "not supported"
|
||||||
|
}
|
||||||
|
|
||||||
gen :: Annex (RemoteGenerator Annex)
|
gen :: Annex (RemoteGenerator Annex)
|
||||||
gen = do
|
gen = do
|
||||||
|
@ -68,8 +72,7 @@ genRemote r = do
|
||||||
removeKey = dropKey r,
|
removeKey = dropKey r,
|
||||||
hasKey = inAnnex r,
|
hasKey = inAnnex r,
|
||||||
hasKeyCheap = not (Git.repoIsUrl r),
|
hasKeyCheap = not (Git.repoIsUrl r),
|
||||||
config = Nothing,
|
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
|
||||||
|
|
13
Remote/S3.hs
13
Remote/S3.hs
|
@ -28,7 +28,11 @@ import UUID
|
||||||
import Config
|
import Config
|
||||||
|
|
||||||
remote :: RemoteType Annex
|
remote :: RemoteType Annex
|
||||||
remote = RemoteType { typename = "S3", generator = gen }
|
remote = RemoteType {
|
||||||
|
typename = "S3",
|
||||||
|
generator = gen,
|
||||||
|
setup = s3Setup
|
||||||
|
}
|
||||||
|
|
||||||
gen :: Annex (RemoteGenerator Annex)
|
gen :: Annex (RemoteGenerator Annex)
|
||||||
gen = do
|
gen = do
|
||||||
|
@ -68,8 +72,7 @@ genRemote r u = do
|
||||||
removeKey = error "TODO",
|
removeKey = error "TODO",
|
||||||
hasKey = error "TODO",
|
hasKey = error "TODO",
|
||||||
hasKeyCheap = False,
|
hasKeyCheap = False,
|
||||||
config = Nothing,
|
config = Nothing
|
||||||
setup = \_ -> return ()
|
|
||||||
}
|
}
|
||||||
|
|
||||||
s3Connection :: Git.Repo -> Annex (Maybe AWSConnection)
|
s3Connection :: Git.Repo -> Annex (Maybe AWSConnection)
|
||||||
|
@ -102,6 +105,10 @@ getS3Config r s def = do
|
||||||
where
|
where
|
||||||
envvar = "ANNEX_" ++ map (\c -> if c == '-' then '_' else toUpper c) s
|
envvar = "ANNEX_" ++ map (\c -> if c == '-' then '_' else toUpper c) s
|
||||||
|
|
||||||
|
s3Setup :: UUID -> M.Map String String -> Annex (M.Map String String)
|
||||||
|
s3Setup u c = do
|
||||||
|
return c
|
||||||
|
|
||||||
{- The UUID of a S3 bucket is stored in a file "git-annex-uuid" in the
|
{- The UUID of a S3 bucket is stored in a file "git-annex-uuid" in the
|
||||||
- bucket. Gets the UUID, or if there is none, sets a new UUID, possibly
|
- bucket. Gets the UUID, or if there is none, sets a new UUID, possibly
|
||||||
- also creating the bucket. -}
|
- also creating the bucket. -}
|
||||||
|
|
|
@ -24,7 +24,9 @@ data RemoteType a = RemoteType {
|
||||||
-- human visible type name
|
-- human visible type name
|
||||||
typename :: String,
|
typename :: String,
|
||||||
-- generates remotes of this type
|
-- generates remotes of this type
|
||||||
generator :: a (RemoteGenerator a)
|
generator :: a (RemoteGenerator a),
|
||||||
|
-- initializes or changes a remote
|
||||||
|
setup :: String -> M.Map String String -> a (M.Map String String)
|
||||||
}
|
}
|
||||||
|
|
||||||
{- An individual remote. -}
|
{- An individual remote. -}
|
||||||
|
@ -48,9 +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 (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
|
||||||
|
|
|
@ -134,11 +134,11 @@ Many git-annex commands will stage changes for later `git commit` by you.
|
||||||
|
|
||||||
* initremote name [param=value ...]
|
* initremote name [param=value ...]
|
||||||
|
|
||||||
Sets up a [[special_remote|special_remotes]] of some type. The remote's
|
Sets up a [[special_remote|special_remotes]]. The remote's
|
||||||
type and configuration is specified by the parameters. If a remote
|
configuration is specified by the parameters. If a remote
|
||||||
with the specified name has already been configured, its configuration
|
with the specified name has already been configured, its configuration
|
||||||
is modified by any values specified. In either case, the remote will be
|
is modified by any values specified. In either case, the remote will be
|
||||||
added added to `.git/config`.
|
added to `.git/config`.
|
||||||
|
|
||||||
Example Amazon S3 remote:
|
Example Amazon S3 remote:
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue