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

@ -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