webapp and assistant glacier support

This commit is contained in:
Joey Hess 2012-11-24 16:30:15 -04:00
parent c282c8b492
commit 463cf58140
23 changed files with 321 additions and 185 deletions

View file

@ -0,0 +1,177 @@
{- git-annex assistant webapp configurators for Amazon AWS services
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
module Assistant.WebApp.Configurators.AWS where
import Assistant.Common
import Assistant.MakeRemote
import Assistant.Sync
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod
#ifdef WITH_S3
import qualified Remote.S3 as S3
#endif
import qualified Remote.Glacier as Glacier
import qualified Remote.Helper.AWS as AWS
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
awsConfigurator :: Widget -> Handler RepHtml
awsConfigurator a = bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Add an Amazon repository"
a
glacierConfigurator :: Widget -> Handler RepHtml
glacierConfigurator a = do
ifM (liftIO $ inPath "glacier")
( awsConfigurator a
, awsConfigurator needglaciercli
)
where
needglaciercli = $(widgetFile "configurators/needglaciercli")
data StorageClass = StandardRedundancy | ReducedRedundancy
deriving (Eq, Enum, Bounded)
instance Show StorageClass where
show StandardRedundancy = "STANDARD"
show ReducedRedundancy = "REDUCED_REDUNDANCY"
data AWSInput = AWSInput
{ accessKeyID :: Text
, secretAccessKey :: Text
-- Free form text for datacenter because Amazon adds new ones.
, datacenter :: Text
-- Only used for S3, not Glacier.
, storageClass :: StorageClass
, repoName :: Text
}
data AWSCreds = AWSCreds Text Text
extractCreds :: AWSInput -> AWSCreds
extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i)
s3InputAForm :: AForm WebApp WebApp AWSInput
s3InputAForm = AWSInput
<$> 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)
]
glacierInputAForm :: AForm WebApp WebApp AWSInput
glacierInputAForm = AWSInput
<$> areq textField "Access Key ID" Nothing
<*> areq passwordField "Secret Access Key" Nothing
<*> areq textField "Datacenter" (Just "us-east-1")
<*> pure StandardRedundancy
<*> areq textField "Repository name" (Just "glacier")
awsCredsAForm :: AForm WebApp WebApp AWSCreds
awsCredsAForm = AWSCreds
<$> areq textField "Access Key ID" Nothing
<*> areq passwordField "Secret Access Key" Nothing
getAddS3R :: Handler RepHtml
#ifdef WITH_S3
getAddS3R = awsConfigurator $ do
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap s3InputAForm
case result of
FormSuccess input -> lift $ do
let name = T.unpack $ repoName input
makeAWSRemote S3.remote (extractCreds input) name setgroup $ M.fromList
[ ("encryption", "shared")
, ("type", "S3")
, ("datacenter", T.unpack $ datacenter input)
, ("storageclass", show $ storageClass input)
]
_ -> do
let authtoken = webAppFormAuthToken
$(widgetFile "configurators/adds3")
where
setgroup r = runAnnex () $
setStandardGroup (Remote.uuid r) TransferGroup
#else
getAddS3R = error "S3 not supported by this build"
#endif
getAddGlacierR :: Handler RepHtml
getAddGlacierR = glacierConfigurator $ do
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap glacierInputAForm
case result of
FormSuccess input -> lift $ do
let name = T.unpack $ repoName input
makeAWSRemote Glacier.remote (extractCreds input) name setgroup $ M.fromList
[ ("encryption", "shared")
, ("type", "glacier")
, ("datacenter", T.unpack $ datacenter input)
]
_ -> do
let authtoken = webAppFormAuthToken
$(widgetFile "configurators/addglacier")
where
setgroup r = runAnnex () $
setStandardGroup (Remote.uuid r) SmallArchiveGroup
getEnableS3R :: UUID -> Handler RepHtml
#ifdef WITH_S3
getEnableS3R = awsConfigurator . enableAWSRemote S3.remote
#else
getEnableS3R _ = error "S3 not supported by this build"
#endif
getEnableGlacierR :: UUID -> Handler RepHtml
getEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote
enableAWSRemote :: RemoteType -> UUID -> Widget
enableAWSRemote remotetype uuid = do
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap awsCredsAForm
case result of
FormSuccess creds -> lift $ do
m <- runAnnex M.empty readRemoteLog
let name = fromJust $ M.lookup "name" $
fromJust $ M.lookup uuid m
makeAWSRemote remotetype creds name (const noop) M.empty
_ -> do
let authtoken = webAppFormAuthToken
description <- lift $ runAnnex "" $
T.pack . concat <$> Remote.prettyListUUIDs [uuid]
$(widgetFile "configurators/enableaws")
makeAWSRemote :: RemoteType -> AWSCreds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
makeAWSRemote remotetype (AWSCreds ak sk) name setup config = do
remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)
r <- liftAssistant $ liftAnnex $ addRemote $ do
makeSpecialRemote name remotetype config
return remotename
setup r
liftAssistant $ syncNewRemote r
redirect $ EditNewCloudRepositoryR $ Remote.uuid r

View file

@ -1,123 +0,0 @@
{- 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 qualified Remote.Helper.AWS as AWS
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)
]
_ -> do
let authtoken = webAppFormAuthToken
$(widgetFile "configurators/adds3")
where
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
_ -> 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 $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)
r <- liftAssistant $ liftAnnex $ addRemote $ do
makeSpecialRemote name S3.remote config
return remotename
setup r
liftAssistant $ syncNewRemote r
redirect $ EditNewCloudRepositoryR $ Remote.uuid r