add a configurator for S3

This commit is contained in:
Joey Hess 2012-09-26 14:44:07 -04:00
parent f18a53eec0
commit 17708dd173
7 changed files with 161 additions and 13 deletions

View file

@ -55,13 +55,10 @@ addRemote a = do
void remoteListRefresh
maybe (error "failed to add remote") return =<< Remote.byName (Just name)
{- Inits a rsync special remote, and returns the name of the remote. -}
{- Inits a rsync special remote, and returns its name. -}
makeRsyncRemote :: String -> String -> Annex String
makeRsyncRemote name location = makeRemote name location $ const $ do
(u, c) <- Command.InitRemote.findByName name
c' <- R.setup Rsync.remote u $ M.union config c
describeUUID u name
configSet u c'
makeRsyncRemote name location = makeRemote name location $
const $ void $ makeSpecialRemote name Rsync.remote config
where
config = M.fromList
[ ("encryption", "shared")
@ -69,6 +66,15 @@ makeRsyncRemote name location = makeRemote name location $ const $ do
, ("type", "rsync")
]
{- Inits a special remote, and returns its name. -}
makeSpecialRemote :: String -> RemoteType -> R.RemoteConfig -> Annex String
makeSpecialRemote name remotetype config = do
(u, c) <- Command.InitRemote.findByName name
c' <- R.setup remotetype u $ M.union config c
describeUUID u name
configSet u c'
return name
{- Returns the name of the git remote it created. If there's already a
- remote at the location, returns its name. -}
makeGitRemote :: String -> String -> Annex String
@ -86,7 +92,7 @@ makeRemote basename location a = do
r <- fromRepo id
if not (any samelocation $ Git.remotes r)
then do
let name = uniqueRemoteName r basename 0
let name = uniqueRemoteName basename 0 r
a name
return name
else return basename
@ -95,10 +101,10 @@ makeRemote basename location a = do
{- Generate an unused name for a remote, adding a number if
- necessary. -}
uniqueRemoteName :: Git.Repo -> String -> Int -> String
uniqueRemoteName r basename n
uniqueRemoteName :: String -> Int -> Git.Repo -> String
uniqueRemoteName basename n r
| null namecollision = name
| otherwise = uniqueRemoteName r basename (succ n)
| otherwise = uniqueRemoteName basename (succ n) r
where
namecollision = filter samename (Git.remotes r)
samename x = Git.remoteName x == Just name

View file

@ -20,6 +20,7 @@ import Assistant.WebApp.Configurators
import Assistant.WebApp.Configurators.Local
import Assistant.WebApp.Configurators.Ssh
import Assistant.WebApp.Configurators.Pairing
import Assistant.WebApp.Configurators.S3
import Assistant.WebApp.Documentation
import Assistant.WebApp.OtherRepos
import Assistant.ThreadedMonad

View file

@ -0,0 +1,95 @@
{- git-annex assistant webapp configurator for Amazon S3
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
module Assistant.WebApp.Configurators.S3 where
import Assistant.Common
import Assistant.MakeRemote
import Assistant.Sync
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Assistant.ThreadedMonad
import Utility.Yesod
import qualified Remote.S3 as S3
import Yesod
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Map as M
data S3Input = S3Input
{ accessKeyID :: Text
, secretAccessKey :: Text
-- Free form text for datacenter because Amazon adds new ones.
, datacenter :: Text
, storageClass :: StorageClass
, repoName :: Text
}
deriving (Show)
data StorageClass = StandardRedundancy | ReducedRedundancy
deriving (Eq, Enum, Bounded)
instance Show StorageClass where
show StandardRedundancy = "STANDARD"
show ReducedRedundancy = "REDUCED_REDUNDANCY"
s3AForm :: AForm WebApp WebApp S3Input
s3AForm = S3Input
<$> areq textField "Access Key ID" Nothing
<*> areq passwordField "Secret Access Key" Nothing
<*> areq textField "Datacenter" (Just "US")
<*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy)
<*> areq textField "Repository name" (Just "S3")
where
storageclasses :: [(Text, StorageClass)]
storageclasses =
[ ("Standard redundancy", StandardRedundancy)
, ("Reduced redundancy (costs less)", ReducedRedundancy)
]
getAddS3R :: Handler RepHtml
getAddS3R = bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Add an Amazon S3 repository"
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap s3AForm
case result of
FormSuccess s3input -> lift $ do
let name = T.unpack $ repoName s3input
name' <- runAnnex name $
fromRepo $ uniqueRemoteName name 0
makeS3Remote s3input name'
_ -> showform form enctype
where
showform form enctype = do
let authtoken = webAppFormAuthToken
$(widgetFile "configurators/adds3")
makeS3Remote :: S3Input -> String -> Handler ()
makeS3Remote s3input name = do
webapp <- getYesod
let st = fromJust $ threadState webapp
liftIO $ do
S3.s3SetCredsEnv
( T.unpack $ accessKeyID s3input
, T.unpack $ secretAccessKey s3input
)
r <- runThreadState st $ addRemote $
makeSpecialRemote name S3.remote config
syncNewRemote st (daemonStatus webapp) (scanRemotes webapp) r
redirect RepositoriesR
where
config = M.fromList
[ ("encryption", "shared")
, ("type", "S3")
, ("datacenter", T.unpack $ datacenter s3input)
, ("storageclass", show $ storageClass s3input)
]

View file

@ -15,7 +15,8 @@
/config/repository/add/ssh/confirm/#SshData ConfirmSshR GET
/config/repository/add/ssh/make/git/#SshData MakeSshGitR GET
/config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET
/config/repository/add/rsync.net AddRsyncNetR GET
/config/repository/add/cloud/rsync.net AddRsyncNetR GET
/config/repository/add/cloud/S3 AddS3R GET
/config/repository/pair/start StartPairR GET
/config/repository/pair/inprogress/#SecretReminder InprogressPairR GET