refactor

Assistant/WebApp/Configurators/AWS.hs

@@ -11,7 +11,6 @@ module Assistant.WebApp.Configurators.AWS where
 
 import Assistant.WebApp.Common
 import Assistant.MakeRemote
-import Assistant.Sync
 #ifdef WITH_S3
 import qualified Remote.S3 as S3
 #endif
@@ -22,9 +21,10 @@ import qualified Remote
 import qualified Types.Remote as Remote
 import Types.Remote (RemoteConfig)
 import Types.StandardGroups
-import Logs.PreferredContent
 import Creds
 import Assistant.Gpg
+import Git.Remote
+import Assistant.WebApp.Utility
 
 import qualified Data.Text as T
 import qualified Data.Map as M
@@ -125,16 +125,13 @@ postAddS3R = awsConfigurator $ do
 	case result of
 		FormSuccess input -> liftH $ do
 			let name = T.unpack $ repoName input
-			makeAWSRemote initSpecialRemote S3.remote (extractCreds input) name setgroup $ M.fromList
+			makeAWSRemote initSpecialRemote S3.remote TransferGroup (extractCreds input) name $ M.fromList
 				[ configureEncryption $ enableEncryption input
 				, ("type", "S3")
 				, ("datacenter", T.unpack $ datacenter input)
 				, ("storageclass", show $ storageClass input)
 				]
 		_ -> $(widgetFile "configurators/adds3")
-  where
-	setgroup r = liftAnnex $
-		setStandardGroup (Remote.uuid r) TransferGroup
 #else
 postAddS3R = error "S3 not supported by this build"
 #endif
@@ -151,15 +148,12 @@ postAddGlacierR = glacierConfigurator $ do
 	case result of
 		FormSuccess input -> liftH $ do
 			let name = T.unpack $ repoName input
-			makeAWSRemote initSpecialRemote Glacier.remote (extractCreds input) name setgroup $ M.fromList
+			makeAWSRemote initSpecialRemote Glacier.remote SmallArchiveGroup (extractCreds input) name $ M.fromList
 				[ configureEncryption $ enableEncryption input
 				, ("type", "glacier")
 				, ("datacenter", T.unpack $ datacenter input)
 				]
 		_ -> $(widgetFile "configurators/addglacier")
-  where
-	setgroup r = liftAnnex $ 
-		setStandardGroup (Remote.uuid r) SmallArchiveGroup
 #else
 postAddGlacierR = error "S3 not supported by this build"
 #endif
@@ -199,7 +193,7 @@ enableAWSRemote remotetype uuid = do
 			m <- liftAnnex readRemoteLog
 			let name = fromJust $ M.lookup "name" $
 				fromJust $ M.lookup uuid m
-			makeAWSRemote enableSpecialRemote remotetype creds name (const noop) M.empty
+			makeAWSRemote enableSpecialRemote remotetype SmallArchiveGroup creds name M.empty
 		_ -> do
 			description <- liftAnnex $
 				T.pack <$> Remote.prettyUUID uuid
@@ -208,14 +202,10 @@ enableAWSRemote remotetype uuid = do
 enableAWSRemote _ _ = error "S3 not supported by this build"
 #endif
 
-makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> AWSCreds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
-makeAWSRemote maker remotetype (AWSCreds ak sk) name setup config = do
+makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> StandardGroup -> AWSCreds -> RemoteName -> RemoteConfig -> Handler ()
+makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config = do
 	liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)
-	r <- liftAnnex $ addRemote $ do
-		maker hostname remotetype config
-	setup r
-	liftAssistant $ syncRemote r
-	redirect $ EditNewCloudRepositoryR $ Remote.uuid r
+	setupCloudRemote defaultgroup $ maker hostname remotetype config
   where
 	{- AWS services use the remote name as the basis for a host
 	 - name, so filter it to contain valid characters. -}

Assistant/WebApp/Configurators/IA.hs

@@ -20,7 +20,6 @@ import qualified Remote
 import qualified Types.Remote as Remote
 import Types.StandardGroups
 import Types.Remote (RemoteConfig)
-import Logs.PreferredContent
 import Logs.Remote
 import qualified Utility.Url as Url
 import Creds
@@ -131,7 +130,7 @@ postAddIAR = iaConfigurator $ do
 	case result of
 		FormSuccess input -> liftH $ do
 			let name = escapeBucket $ T.unpack $ itemName input
-			AWS.makeAWSRemote initSpecialRemote S3.remote (extractCreds input) name setgroup $
+			AWS.makeAWSRemote initSpecialRemote S3.remote PublicGroup (extractCreds input) name $
 				M.fromList $ catMaybes
 					[ Just $ configureEncryption NoEncryption
 					, Just ("type", "S3")
@@ -147,9 +146,6 @@ postAddIAR = iaConfigurator $ do
 					, Just ("preferreddir", name)
 					]
 		_ -> $(widgetFile "configurators/addia")
-  where
-	setgroup r = liftAnnex $
-		setStandardGroup (Remote.uuid r) PublicGroup
 #else
 postAddIAR = error "S3 not supported by this build"
 #endif
@@ -175,7 +171,7 @@ enableIARemote uuid = do
 			m <- liftAnnex readRemoteLog
 			let name = fromJust $ M.lookup "name" $
 				fromJust $ M.lookup uuid m
-			AWS.makeAWSRemote enableSpecialRemote S3.remote creds name (const noop) M.empty
+			AWS.makeAWSRemote enableSpecialRemote S3.remote PublicGroup creds name M.empty
 		_ -> do
 			description <- liftAnnex $
 				T.pack <$> Remote.prettyUUID uuid

Assistant/WebApp/Configurators/Ssh.hs

@@ -21,11 +21,11 @@ import Logs.PreferredContent
 import Types.StandardGroups
 import Utility.UserInfo
 import Utility.Gpg
-import Assistant.Sync
 import qualified Remote.GCrypt as GCrypt
 import qualified Git.GCrypt
 import Types.Remote (RemoteConfigKey)
 import Git.Remote
+import Assistant.WebApp.Utility
 
 import qualified Data.Text as T
 import qualified Data.Map as M
@@ -296,26 +296,26 @@ getRetrySshR sshdata = do
 	redirect $ either (const $ ConfirmSshR sshdata) ConfirmSshR s
 
 getMakeSshGitR :: SshData -> Handler Html
-getMakeSshGitR = makeSsh False setupGroup
+getMakeSshGitR = makeSsh False
 
 getMakeSshRsyncR :: SshData -> Handler Html
-getMakeSshRsyncR = makeSsh True setupGroup
+getMakeSshRsyncR = makeSsh True
 
-makeSsh :: Bool -> (Remote -> Handler ()) -> SshData -> Handler Html
-makeSsh rsync setup sshdata
+makeSsh :: Bool -> SshData -> Handler Html
+makeSsh rsync sshdata
 	| needsPubKey sshdata = do
 		keypair <- liftIO genSshKeyPair
 		sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
-		makeSsh' rsync setup sshdata sshdata' (Just keypair)
+		makeSsh' rsync sshdata sshdata' (Just keypair)
 	| sshPort sshdata /= 22 = do
 		sshdata' <- liftIO $ setSshConfig sshdata []
-		makeSsh' rsync setup sshdata sshdata' Nothing
-	| otherwise = makeSsh' rsync setup sshdata sshdata Nothing
+		makeSsh' rsync sshdata sshdata' Nothing
+	| otherwise = makeSsh' rsync sshdata sshdata Nothing
 
-makeSsh' :: Bool -> (Remote -> Handler ()) -> SshData -> SshData -> Maybe SshKeyPair -> Handler Html
-makeSsh' rsync setup origsshdata sshdata keypair = do
+makeSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> Handler Html
+makeSsh' rsync origsshdata sshdata keypair = do
 	sshSetup ["-p", show (sshPort origsshdata), sshhost, remoteCommand] "" $
-		makeSshRepo rsync setup sshdata
+		makeSshRepo rsync sshdata
   where
 	sshhost = genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
 	remotedir = T.unpack $ sshDirectory sshdata
@@ -329,10 +329,10 @@ makeSsh' rsync setup origsshdata sshdata keypair = do
 			else Nothing
 		]
 
-makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler Html
-makeSshRepo forcersync setup sshdata = do
+makeSshRepo :: Bool -> SshData -> Handler Html
+makeSshRepo forcersync sshdata = do
 	r <- liftAssistant $ makeSshRemote forcersync sshdata Nothing
-	setup r
+	liftAnnex $ setStandardGroup (Remote.uuid r) TransferGroup
 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r
 
 getAddRsyncNetR :: Handler Html
@@ -371,27 +371,23 @@ postAddRsyncNetR = do
 			$(widgetFile "configurators/rsync.net/encrypt")					
 
 getMakeRsyncNetSharedR :: SshData -> Handler Html
-getMakeRsyncNetSharedR sshdata = makeSshRepo True setupGroup sshdata
+getMakeRsyncNetSharedR sshdata = makeSshRepo True sshdata
 
 {- Make a gcrypt special remote on rsync.net. -}
 getMakeRsyncNetGCryptR :: SshData -> RepoKey -> Handler Html
 getMakeRsyncNetGCryptR sshdata NoRepoKey = whenGcryptInstalled $
 	withNewSecretKey $ getMakeRsyncNetGCryptR sshdata . RepoKey
 getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $ do
-	sshSetup [sshhost, gitinit] [] $ do
-		r <- liftAnnex $ addRemote $
+	sshSetup [sshhost, gitinit] [] $
+		setupCloudRemote TransferGroup $ 
 			makeGCryptRemote (sshRepoName sshdata) (sshUrl True sshdata) keyid
-		setupGroup r
-		liftAssistant $ syncRemote r
-		redirect $ EditNewCloudRepositoryR $ Remote.uuid r
   where
 	sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
 	gitinit = "git init --bare " ++ T.unpack (sshDirectory sshdata)
 
 enableRsyncNet :: SshInput -> String -> Handler Html
 enableRsyncNet sshinput reponame = 
-	prepRsyncNet sshinput reponame $ \sshdata ->
-		makeSshRepo True (const noop) sshdata
+	prepRsyncNet sshinput reponame $ makeSshRepo True
 
 enableRsyncNetGCrypt :: SshInput -> String -> Handler Html
 enableRsyncNetGCrypt sshinput reponame = 
@@ -399,13 +395,10 @@ enableRsyncNetGCrypt sshinput reponame =
   		let repourl = sshUrl True sshdata
 		pr <- liftAnnex $ inRepo $ Git.GCrypt.probeRepo repourl
 		case pr of
-			Git.GCrypt.Decryptable -> do
-				r <- liftAnnex $ addRemote $
+			Git.GCrypt.Decryptable ->
+				setupCloudRemote TransferGroup $ 
 					enableSpecialRemote reponame GCrypt.remote $ M.fromList
 						[("gitrepo", repourl)]
-				setupGroup r
-				liftAssistant $ syncRemote r
-				redirect $ EditNewCloudRepositoryR $ Remote.uuid r		
 			Git.GCrypt.NotDecryptable ->
 				error "The drive contains a git repository that is encrypted with a GnuPG key that you do not have."
 			Git.GCrypt.NotEncrypted ->
@@ -446,6 +439,3 @@ prepRsyncNet sshinput reponame a = do
 isRsyncNet :: Maybe Text -> Bool
 isRsyncNet Nothing = False
 isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host
-
-setupGroup :: Remote -> Handler ()
-setupGroup r = liftAnnex $ setStandardGroup (Remote.uuid r) TransferGroup

Assistant/WebApp/Configurators/WebDAV.hs

@@ -14,13 +14,13 @@ import Creds
 #ifdef WITH_WEBDAV
 import qualified Remote.WebDAV as WebDAV
 import Assistant.MakeRemote
-import Assistant.Sync
 import qualified Remote
 import Types.Remote (RemoteConfig)
 import Types.StandardGroups
-import Logs.PreferredContent
 import Logs.Remote
 import Assistant.Gpg
+import Assistant.WebApp.Utility
+import Git.Remote
 
 import qualified Data.Map as M
 #endif
@@ -70,7 +70,7 @@ postAddBoxComR = boxConfigurator $ do
 		runFormPost $ renderBootstrap $ boxComAForm defcreds
 	case result of
 		FormSuccess input -> liftH $ 
-			makeWebDavRemote initSpecialRemote "box.com" (toCredPair input) setgroup $ M.fromList
+			makeWebDavRemote initSpecialRemote "box.com" (toCredPair input) $ M.fromList
 				[ configureEncryption $ enableEncryption input
 				, ("embedcreds", if embedCreds input then "yes" else "no")
 				, ("type", "webdav")
@@ -81,9 +81,6 @@ postAddBoxComR = boxConfigurator $ do
 				, ("chunksize", "10mb")
 				]
 		_ -> $(widgetFile "configurators/addbox.com")
-  where
-	setgroup r = liftAnnex $
-		setStandardGroup (Remote.uuid r) TransferGroup
 #else
 postAddBoxComR = error "WebDAV not supported by this build"
 #endif
@@ -101,7 +98,7 @@ postEnableWebDAVR uuid = do
 		getRemoteCredPairFor "webdav" c (WebDAV.davCreds uuid)
 	case mcreds of
 		Just creds -> webDAVConfigurator $ liftH $
-			makeWebDavRemote enableSpecialRemote name creds (const noop) M.empty
+			makeWebDavRemote enableSpecialRemote name creds M.empty
 		Nothing
 			| "box.com/" `isInfixOf` url ->
 				boxConfigurator $ showform name url
@@ -116,7 +113,7 @@ postEnableWebDAVR uuid = do
 			runFormPost $ renderBootstrap $ webDAVCredsAForm defcreds
 		case result of
 			FormSuccess input -> liftH $
-				makeWebDavRemote enableSpecialRemote name (toCredPair input) (const noop) M.empty
+				makeWebDavRemote enableSpecialRemote name (toCredPair input) M.empty
 			_ -> do
 				description <- liftAnnex $
 					T.pack <$> Remote.prettyUUID uuid
@@ -126,13 +123,10 @@ postEnableWebDAVR _ = error "WebDAV not supported by this build"
 #endif
 
 #ifdef WITH_WEBDAV
-makeWebDavRemote :: SpecialRemoteMaker -> String -> CredPair -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
-makeWebDavRemote maker name creds setup config = do
+makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler ()
+makeWebDavRemote maker name creds config = do
 	liftIO $ WebDAV.setCredsEnv creds
-	r <- liftAnnex $ addRemote $ maker name WebDAV.remote config
-	setup r
-	liftAssistant $ syncRemote r
-	redirect $ EditNewCloudRepositoryR $ Remote.uuid r
+	setupCloudRemote TransferGroup $ maker name WebDAV.remote config
 
 {- Only returns creds previously used for the same hostname. -}
 previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair)

Assistant/WebApp/Utility.hs

@@ -24,11 +24,16 @@ import Config.Files
 import Git.Config
 import Assistant.Threads.Watcher
 import Assistant.NamedThread
+import Types.StandardGroups
+import Git.Remote
+import Logs.PreferredContent
+import Assistant.MakeRemote
 
 import qualified Data.Map as M
 import Control.Concurrent
 import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
 import System.Posix.Process (getProcessGroupIDOf)
+import Utility.Yesod
 
 {- Use Nothing to change autocommit setting; or a remote to change
  - its sync setting. -}
@@ -118,3 +123,14 @@ startTransfer t = do
 
 getCurrentTransfers :: Handler TransferMap
 getCurrentTransfers = currentTransfers <$> liftAssistant getDaemonStatus
+
+{- Runs an action that creates or enables a cloud remote,
+ - and finishes setting it up; adding it to a group if it's not already in
+ - one, starts syncing with it, and finishes by displaying the page to edit
+ - it. -}
+setupCloudRemote :: StandardGroup -> Annex RemoteName -> Handler a
+setupCloudRemote defaultgroup maker = do
+	r <- liftAnnex $ addRemote maker
+	liftAnnex $ setStandardGroup (Remote.uuid r) defaultgroup
+	liftAssistant $ syncRemote r
+	redirect $ EditNewCloudRepositoryR $ Remote.uuid r