From 76657735938ba9c1484cd017b9dab27d1c2ef599 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 27 Sep 2013 00:15:50 -0400 Subject: [PATCH] refactor --- Assistant/WebApp/Configurators/AWS.hs | 26 ++++-------- Assistant/WebApp/Configurators/IA.hs | 8 +--- Assistant/WebApp/Configurators/Ssh.hs | 50 ++++++++++-------------- Assistant/WebApp/Configurators/WebDAV.hs | 22 ++++------- Assistant/WebApp/Utility.hs | 16 ++++++++ 5 files changed, 54 insertions(+), 68 deletions(-) diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs index de59240b45..f38b3e009d 100644 --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/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. -} diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs index a3120e01a1..36f3bd34b9 100644 --- a/Assistant/WebApp/Configurators/IA.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index d11d1a44ab..d68028dee5 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs index cf367bb315..67701768ce 100644 --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/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) diff --git a/Assistant/WebApp/Utility.hs b/Assistant/WebApp/Utility.hs index 027fc26544..d922de8bd9 100644 --- a/Assistant/WebApp/Utility.hs +++ b/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