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