blob: 39ec3665391b4366a260ce90df9d238edcea8c94 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
{- git-annex command
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Command.InitRemote where
import qualified Data.Map as M
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
command :: [Command]
command = [repoCommand "initremote"
(paramPair paramName $
paramOptional $ paramRepeating $ paramKeyValue) seek
"sets up a special (non-git) remote"]
seek :: [CommandSeek]
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
return $ Just $ perform t u $ M.union config c
where
ws = words params
name = head ws
config = Remote.keyValToMap $ tail ws
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'
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
Nothing -> False
Just n'
| 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"
|
