mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

refactor

Browse source
This commit is contained in:
Joey Hess 2013-09-27 00:15:50 -04:00
parent 1550759220
commit 7665773593
5 changed files with 54 additions and 68 deletions
Download patch file Download diff file Expand all files Collapse all files

26
Assistant/WebApp/Configurators/AWS.hs
View file

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

8
Assistant/WebApp/Configurators/IA.hs
View file

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

50
Assistant/WebApp/Configurators/Ssh.hs
View file

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

22
Assistant/WebApp/Configurators/WebDAV.hs
View file

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

16
Assistant/WebApp/Utility.hs
View file

@ -24,11 +24,16 @@ import Config.Files
import Git.Config import Git.Config
import Assistant.Threads.Watcher import Assistant.Threads.Watcher
import Assistant.NamedThread import Assistant.NamedThread
import Types.StandardGroups
import Git.Remote
import Logs.PreferredContent
import Assistant.MakeRemote
import qualified Data.Map as M import qualified Data.Map as M
import Control.Concurrent import Control.Concurrent
import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL) import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
import System.Posix.Process (getProcessGroupIDOf) import System.Posix.Process (getProcessGroupIDOf)
import Utility.Yesod
{- Use Nothing to change autocommit setting; or a remote to change {- Use Nothing to change autocommit setting; or a remote to change
- its sync setting. -} - its sync setting. -}
@ -118,3 +123,14 @@ startTransfer t = do
getCurrentTransfers :: Handler TransferMap getCurrentTransfers :: Handler TransferMap
getCurrentTransfers = currentTransfers <$> liftAssistant getDaemonStatus 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