125 lines
3.9 KiB
Haskell
125 lines
3.9 KiB
Haskell
{- 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 Utility.Yesod
|
|
import qualified Remote.S3 as S3
|
|
import Logs.Remote
|
|
import qualified Remote
|
|
import Types.Remote (RemoteConfig)
|
|
import Types.StandardGroups
|
|
import Logs.PreferredContent
|
|
|
|
import Yesod
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Map as M
|
|
|
|
s3Configurator :: Widget -> Handler RepHtml
|
|
s3Configurator a = bootstrap (Just Config) $ do
|
|
sideBarDisplay
|
|
setTitle "Add an Amazon S3 repository"
|
|
a
|
|
|
|
data StorageClass = StandardRedundancy | ReducedRedundancy
|
|
deriving (Eq, Enum, Bounded)
|
|
|
|
instance Show StorageClass where
|
|
show StandardRedundancy = "STANDARD"
|
|
show ReducedRedundancy = "REDUCED_REDUNDANCY"
|
|
|
|
data S3Input = S3Input
|
|
{ accessKeyID :: Text
|
|
, secretAccessKey :: Text
|
|
-- Free form text for datacenter because Amazon adds new ones.
|
|
, datacenter :: Text
|
|
, storageClass :: StorageClass
|
|
, repoName :: Text
|
|
}
|
|
|
|
data S3Creds = S3Creds Text Text
|
|
|
|
extractCreds :: S3Input -> S3Creds
|
|
extractCreds i = S3Creds (accessKeyID i) (secretAccessKey i)
|
|
|
|
s3InputAForm :: AForm WebApp WebApp S3Input
|
|
s3InputAForm = 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)
|
|
]
|
|
|
|
s3CredsAForm :: AForm WebApp WebApp S3Creds
|
|
s3CredsAForm = S3Creds
|
|
<$> areq textField "Access Key ID" Nothing
|
|
<*> areq passwordField "Secret Access Key" Nothing
|
|
|
|
getAddS3R :: Handler RepHtml
|
|
getAddS3R = s3Configurator $ do
|
|
((result, form), enctype) <- lift $
|
|
runFormGet $ renderBootstrap s3InputAForm
|
|
case result of
|
|
FormSuccess s3input -> lift $ do
|
|
let name = T.unpack $ repoName s3input
|
|
makeS3Remote (extractCreds s3input) name setgroup $ M.fromList
|
|
[ ("encryption", "shared")
|
|
, ("type", "S3")
|
|
, ("datacenter", T.unpack $ datacenter s3input)
|
|
, ("storageclass", show $ storageClass s3input)
|
|
]
|
|
_ -> showform form enctype
|
|
where
|
|
showform form enctype = do
|
|
let authtoken = webAppFormAuthToken
|
|
$(widgetFile "configurators/adds3")
|
|
setgroup r = runAnnex () $
|
|
setStandardGroup (Remote.uuid r) TransferGroup
|
|
|
|
getEnableS3R :: UUID -> Handler RepHtml
|
|
getEnableS3R uuid = s3Configurator $ do
|
|
((result, form), enctype) <- lift $
|
|
runFormGet $ renderBootstrap s3CredsAForm
|
|
case result of
|
|
FormSuccess s3creds -> lift $ do
|
|
m <- runAnnex M.empty readRemoteLog
|
|
let name = fromJust $ M.lookup "name" $
|
|
fromJust $ M.lookup uuid m
|
|
makeS3Remote s3creds name (const noop) M.empty
|
|
_ -> showform form enctype
|
|
where
|
|
showform form enctype = do
|
|
let authtoken = webAppFormAuthToken
|
|
description <- lift $ runAnnex "" $
|
|
T.pack . concat <$> Remote.prettyListUUIDs [uuid]
|
|
$(widgetFile "configurators/enables3")
|
|
|
|
makeS3Remote :: S3Creds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
|
|
makeS3Remote (S3Creds ak sk) name setup config = do
|
|
remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
|
|
liftIO $ S3.s3SetCredsEnv ( T.unpack ak, T.unpack sk)
|
|
r <- runAssistantY $ liftAnnex $ addRemote $ do
|
|
makeSpecialRemote name S3.remote config
|
|
return remotename
|
|
setup r
|
|
runAssistantY $ syncNewRemote r
|
|
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
|