9eaabf0382
Avoid stomping on existing group and preferred content settings when enabling or combining with an already existing remote. Two level fix. First, use defaultStandardGroup rather than setStandardGroup, so if there is an existing configuration in the git-annex branch, it's not overwritten. To handle pre-existing ssh remotes (including gcrypt), a second level is needed, because before syncing with the remote, it's configuration won't be available locally. (And syncing could take a long time.) So, in this case, keep track of whether the remote is being created or enabled, and only set configs when creating it. This commit was sponsored by Anders Lannerback.
45 lines
1.4 KiB
Haskell
45 lines
1.4 KiB
Haskell
{- git-annex assistant webapp making remotes
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.WebApp.MakeRemote (
|
|
module Assistant.MakeRemote,
|
|
module Assistant.WebApp.MakeRemote
|
|
) where
|
|
|
|
import Assistant.Common
|
|
import Assistant.WebApp.Types
|
|
import Assistant.Sync
|
|
import qualified Remote
|
|
import qualified Types.Remote as Remote
|
|
import qualified Config
|
|
import Config.Cost
|
|
import Types.StandardGroups
|
|
import Git.Types (RemoteName)
|
|
import Logs.PreferredContent
|
|
import Assistant.MakeRemote
|
|
|
|
import Utility.Yesod
|
|
|
|
{- Runs an action that creates or enables a cloud remote,
|
|
- and finishes setting it up, then starts syncing with it,
|
|
- and finishes by displaying the page to edit it.
|
|
-
|
|
- This includes displaying the connectionNeeded nudge if appropariate.
|
|
-}
|
|
setupCloudRemote :: StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
|
|
setupCloudRemote = setupRemote postsetup . Just
|
|
where
|
|
postsetup = redirect . EditNewCloudRepositoryR . Remote.uuid
|
|
|
|
setupRemote :: (Remote -> Handler a) -> Maybe StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
|
|
setupRemote postsetup mgroup mcost getname = do
|
|
r <- liftAnnex $ addRemote getname
|
|
liftAnnex $ do
|
|
maybe noop (defaultStandardGroup (Remote.uuid r)) mgroup
|
|
maybe noop (Config.setRemoteCost (Remote.repo r)) mcost
|
|
liftAssistant $ syncRemote r
|
|
postsetup r
|