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.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. -}