refactor
This commit is contained in:
Joey Hess
parent
1550759220
commit
7665773593
5 changed files with 54 additions and 68 deletions
|
|
@ -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. -}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue