122 lines
3.9 KiB
Haskell
122 lines
3.9 KiB
Haskell
{- git-annex assistant remote creation utilities
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.MakeRemote where
|
|
|
|
import Assistant.Common
|
|
import Assistant.Ssh
|
|
import Assistant.Sync
|
|
import qualified Types.Remote as R
|
|
import qualified Remote
|
|
import Remote.List
|
|
import qualified Remote.Rsync as Rsync
|
|
import qualified Git
|
|
import qualified Git.Command
|
|
import qualified Command.InitRemote
|
|
import Logs.UUID
|
|
import Logs.Remote
|
|
import Git.Remote
|
|
import Config
|
|
import Config.Cost
|
|
|
|
import qualified Data.Text as T
|
|
import qualified Data.Map as M
|
|
|
|
{- Sets up and begins syncing with a new ssh or rsync remote. -}
|
|
makeSshRemote :: Bool -> SshData -> Maybe Cost -> Assistant Remote
|
|
makeSshRemote forcersync sshdata mcost = do
|
|
r <- liftAnnex $
|
|
addRemote $ maker (sshRepoName sshdata) sshurl
|
|
liftAnnex $ maybe noop (setRemoteCost r) mcost
|
|
syncRemote r
|
|
return r
|
|
where
|
|
rsync = forcersync || rsyncOnly sshdata
|
|
maker
|
|
| rsync = makeRsyncRemote
|
|
| otherwise = makeGitRemote
|
|
sshurl = T.unpack $ T.concat $
|
|
if rsync
|
|
then [u, h, T.pack ":", sshDirectory sshdata, T.pack "/"]
|
|
else [T.pack "ssh://", u, h, d, T.pack "/"]
|
|
where
|
|
u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata
|
|
h = sshHostName sshdata
|
|
d
|
|
| T.pack "/" `T.isPrefixOf` sshDirectory sshdata = sshDirectory sshdata
|
|
| otherwise = T.concat [T.pack "/~/", sshDirectory sshdata]
|
|
|
|
{- Runs an action that returns a name of the remote, and finishes adding it. -}
|
|
addRemote :: Annex String -> Annex Remote
|
|
addRemote a = do
|
|
name <- a
|
|
void remoteListRefresh
|
|
maybe (error "failed to add remote") return
|
|
=<< Remote.byName (Just name)
|
|
|
|
{- Inits a rsync special remote, and returns its name. -}
|
|
makeRsyncRemote :: String -> String -> Annex String
|
|
makeRsyncRemote name location = makeRemote name location $
|
|
const $ makeSpecialRemote name Rsync.remote config
|
|
where
|
|
config = M.fromList
|
|
[ ("encryption", "shared")
|
|
, ("rsyncurl", location)
|
|
, ("type", "rsync")
|
|
]
|
|
|
|
{- Inits a special remote. Currently, only 'weak' ciphers can be
|
|
- generated from the assistant, because otherwise GnuPG may block once
|
|
- the entropy pool is drained, and as of now there's no way to tell the
|
|
- user to perform IO actions to refill the pool. -}
|
|
makeSpecialRemote :: String -> RemoteType -> R.RemoteConfig -> Annex ()
|
|
makeSpecialRemote name remotetype config = do
|
|
(u, c) <- Command.InitRemote.findByName name
|
|
c' <- R.setup remotetype u $
|
|
M.insert "highRandomQuality" "false" $ M.union config c
|
|
describeUUID u name
|
|
configSet u c'
|
|
|
|
{- Returns the name of the git remote it created. If there's already a
|
|
- remote at the location, returns its name. -}
|
|
makeGitRemote :: String -> String -> Annex String
|
|
makeGitRemote basename location = makeRemote basename location $ \name ->
|
|
void $ inRepo $ Git.Command.runBool
|
|
[Param "remote", Param "add", Param name, Param location]
|
|
|
|
{- If there's not already a remote at the location, adds it using the
|
|
- action, which is passed the name of the remote to make.
|
|
-
|
|
- Returns the name of the remote. -}
|
|
makeRemote :: String -> String -> (String -> Annex ()) -> Annex String
|
|
makeRemote basename location a = do
|
|
g <- gitRepo
|
|
if not (any samelocation $ Git.remotes g)
|
|
then do
|
|
|
|
let name = uniqueRemoteName basename 0 g
|
|
a name
|
|
return name
|
|
else return basename
|
|
where
|
|
samelocation x = Git.repoLocation x == location
|
|
|
|
{- Generate an unused name for a remote, adding a number if
|
|
- necessary.
|
|
-
|
|
- Ensures that the returned name is a legal git remote name. -}
|
|
uniqueRemoteName :: String -> Int -> Git.Repo -> String
|
|
uniqueRemoteName basename n r
|
|
| null namecollision = name
|
|
| otherwise = uniqueRemoteName legalbasename (succ n) r
|
|
where
|
|
namecollision = filter samename (Git.remotes r)
|
|
samename x = Git.remoteName x == Just name
|
|
name
|
|
| n == 0 = legalbasename
|
|
| otherwise = legalbasename ++ show n
|
|
legalbasename = makeLegalName basename
|