1{- git-annex assistant remote creation utilities
2 -
3 - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE OverloadedStrings #-}
9
10module Assistant.MakeRemote where
11
12import Assistant.Common
13import Assistant.Ssh
14import qualified Types.Remote as R
15import qualified Remote
16import Remote.List.Util
17import qualified Remote.Rsync as Rsync
18import qualified Remote.GCrypt as GCrypt
19import qualified Git
20import qualified Git.Command
21import qualified Annex
22import qualified Annex.SpecialRemote
23import Annex.SpecialRemote.Config
24import Logs.UUID
25import Logs.Remote
26import Git.Remote
27import Git.Types (RemoteName)
28import Creds
29import Assistant.Gpg
30import Utility.Gpg (KeyId)
31import Types.GitConfig
32import Config
33import Types.ProposedAccepted
34
35import qualified Data.Map as M
36
37{- Sets up a new git or rsync remote, accessed over ssh. -}
38makeSshRemote :: SshData -> Annex RemoteName
39makeSshRemote sshdata = maker (sshRepoName sshdata) (genSshUrl sshdata)
40  where
41	maker
42		| onlyCapability sshdata RsyncCapable = makeRsyncRemote
43		| otherwise = makeGitRemote
44
45{- Runs an action that returns a name of the remote, and finishes adding it. -}
46addRemote :: Annex RemoteName -> Annex Remote
47addRemote a = do
48	name <- a
49	remotesChanged
50	maybe (error "failed to add remote") return
51		=<< Remote.byName (Just name)
52
53{- Inits a rsync special remote, and returns its name. -}
54makeRsyncRemote :: RemoteName -> String -> Annex String
55makeRsyncRemote name location = makeRemote name location $ const $ void $
56	go =<< Annex.SpecialRemote.findExisting name
57  where
58	go Nothing = setupSpecialRemote name Rsync.remote config Nothing
59		(Nothing, R.Init, Annex.SpecialRemote.newConfig name Nothing mempty mempty) Nothing
60	go (Just (u, c, mcu)) = setupSpecialRemote name Rsync.remote config Nothing
61		(Just u, R.Enable c, c) mcu
62	config = M.fromList
63		[ (encryptionField, Proposed "shared")
64		, (Proposed "rsyncurl", Proposed location)
65		, (typeField, Proposed "rsync")
66		]
67
68{- Inits a gcrypt special remote, and returns its name. -}
69makeGCryptRemote :: RemoteName -> String -> KeyId -> Annex RemoteName
70makeGCryptRemote remotename location keyid =
71	initSpecialRemote remotename GCrypt.remote Nothing $ M.fromList
72		[ (typeField, Proposed "gcrypt")
73		, (Proposed "gitrepo", Proposed location)
74		, configureEncryption HybridEncryption
75		, (Proposed "keyid", Proposed keyid)
76		]
77
78type SpecialRemoteMaker = RemoteName -> RemoteType -> Maybe CredPair -> R.RemoteConfig -> Annex RemoteName
79
80{- Inits a new special remote. The name is used as a suggestion, but
81 - will be changed if there is already a special remote with that name. -}
82initSpecialRemote :: SpecialRemoteMaker
83initSpecialRemote name remotetype mcreds config = go 0
84  where
85	go :: Int -> Annex RemoteName
86	go n = do
87		let fullname = if n == 0  then name else name ++ show n
88		Annex.SpecialRemote.findExisting fullname >>= \case
89			Nothing -> setupSpecialRemote fullname remotetype config mcreds
90				(Nothing, R.Init, Annex.SpecialRemote.newConfig fullname Nothing mempty mempty) Nothing
91			Just _ -> go (n + 1)
92
93{- Enables an existing special remote. -}
94enableSpecialRemote :: SpecialRemoteMaker
95enableSpecialRemote name remotetype mcreds config =
96	Annex.SpecialRemote.findExisting name >>= \case
97		Nothing -> error $ "Cannot find a special remote named " ++ name
98		Just (u, c, mcu) -> setupSpecialRemote' False name remotetype config mcreds (Just u, R.Enable c, c) mcu
99
100setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Maybe (Annex.SpecialRemote.ConfigFrom UUID) -> Annex RemoteName
101setupSpecialRemote = setupSpecialRemote' True
102
103setupSpecialRemote' :: Bool -> RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Maybe (Annex.SpecialRemote.ConfigFrom UUID) -> Annex RemoteName
104setupSpecialRemote' setdesc name remotetype config mcreds (mu, ss, c) mcu = do
105	{- Currently, only 'weak' ciphers can be generated from the
106	 - assistant, because otherwise GnuPG may block once the entropy
107	 - pool is drained, and as of now there's no way to tell the user
108	 - to perform IO actions to refill the pool. -}
109	let weakc = M.insert (Proposed "highRandomQuality") (Proposed "false") (M.union config c)
110	dummycfg <- liftIO dummyRemoteGitConfig
111	(c', u) <- R.setup remotetype ss mu mcreds weakc dummycfg
112	case mcu of
113		Nothing ->
114			configSet u c'
115		Just (Annex.SpecialRemote.ConfigFrom cu) -> do
116			setConfig (remoteAnnexConfig c' "config-uuid") (fromUUID cu)
117			configSet cu c'
118	when setdesc $
119		whenM (isNothing . M.lookup u <$> uuidDescMap) $
120			describeUUID u (toUUIDDesc name)
121	return name
122
123{- Returns the name of the git remote it created. If there's already a
124 - remote at the location, returns its name. -}
125makeGitRemote :: String -> String -> Annex RemoteName
126makeGitRemote basename location = makeRemote basename location $ \name ->
127	void $ inRepo $ Git.Command.runBool
128		[Param "remote", Param "add", Param name, Param location]
129
130{- If there's not already a remote at the location, adds it using the
131 - action, which is passed the name of the remote to make.
132 -
133 - Returns the name of the remote. -}
134makeRemote :: String -> String -> (RemoteName -> Annex ()) -> Annex RemoteName
135makeRemote basename location a = do
136	rs <- Annex.getGitRemotes
137	if not (any samelocation rs)
138		then do
139			let name = uniqueRemoteName basename 0 rs
140			a name
141			return name
142		else return basename
143  where
144	samelocation x = Git.repoLocation x == location
145
146{- Given a list of all remotes, generate an unused name for a new
147 - remote, adding a number if necessary.
148 -
149 - Ensures that the returned name is a legal git remote name. -}
150uniqueRemoteName :: String -> Int -> [Git.Repo] -> RemoteName
151uniqueRemoteName basename n rs
152	| null namecollision = name
153	| otherwise = uniqueRemoteName legalbasename (succ n) rs
154  where
155	namecollision = filter samename rs
156	samename x = Git.remoteName x == Just name
157	name
158		| n == 0 = legalbasename
159		| otherwise = legalbasename ++ show n
160	legalbasename = makeLegalName basename
161
162{- Finds a CredPair belonging to any Remote that is of a given type
163 - and matches some other criteria.
164 -
165 - This can be used as a default when another repository is being set up
166 - using the same service.
167 -
168 - A function must be provided that returns the CredPairStorage
169 - to use for a particular Remote's uuid.
170 -}
171previouslyUsedCredPair
172	:: (UUID -> CredPairStorage)
173	-> RemoteType
174	-> (Remote -> Bool)
175	-> Annex (Maybe CredPair)
176previouslyUsedCredPair getstorage remotetype criteria =
177	getM fromstorage
178		=<< filter criteria . filter sametype
179		<$> Remote.remoteList
180  where
181	sametype r = R.typename (R.remotetype r) == R.typename remotetype
182	fromstorage r = do
183		let storage = getstorage (R.uuid r)
184		getRemoteCredPair (R.config r) (R.gitconfig r) storage
185