initremote works

This commit is contained in:
Joey Hess 2011-03-29 14:55:59 -04:00
parent 05751d55cd
commit 0a4c610b4f
6 changed files with 85 additions and 30 deletions

View file

@ -12,7 +12,12 @@ import Control.Monad (when)
import Control.Monad.State (liftIO)
import Command
import qualified Annex
import qualified Remote
import qualified RemoteClass
import qualified GitRepo as Git
import Utility
import Types
import UUID
import Messages
@ -28,27 +33,49 @@ seek = [withString start]
start :: CommandStartString
start params = notBareRepo $ do
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
m <- Remote.readRemoteLog
(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
return $ Just $ perform t u $ M.union config c
where
ws = words params
name = head ws
config = Remote.keyValToMap $ tail ws
perform :: String -> UUID -> M.Map String String -> CommandPerform
perform name uuid config = do
liftIO $ putStrLn $ show $ (uuid, config)
return Nothing
perform :: RemoteClass.RemoteType Annex -> UUID -> M.Map String String -> CommandPerform
perform t u c = do
c' <- RemoteClass.setup t u c
return $ Just $ cleanup u c'
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
cleanup :: UUID -> M.Map String String -> CommandCleanup
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
matches = filter (matching . snd) $ M.toList m
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
| 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. -}
nameKey :: String
nameKey = "name"
{- The type of a remote is stored in its config using this key. -}
typeKey :: String
typeKey = "type"