2012-11-24 20:30:15 +00:00
|
|
|
{- 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.
|
|
|
|
-}
|
|
|
|
|
2012-12-02 21:32:54 +00:00
|
|
|
{-# LANGUAGE CPP, FlexibleContexts, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
2012-11-24 20:30:15 +00:00
|
|
|
|
|
|
|
module Assistant.WebApp.Configurators.AWS where
|
|
|
|
|
2012-11-25 04:26:46 +00:00
|
|
|
import Assistant.WebApp.Common
|
2012-11-24 20:30:15 +00:00
|
|
|
import Assistant.MakeRemote
|
|
|
|
import Assistant.Sync
|
|
|
|
#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 qualified Data.Text as T
|
|
|
|
import qualified Data.Map as M
|
2013-01-14 16:54:29 +00:00
|
|
|
import Data.Char
|
2012-11-24 20:30:15 +00:00
|
|
|
|
|
|
|
awsConfigurator :: Widget -> Handler RepHtml
|
2012-12-30 03:10:18 +00:00
|
|
|
awsConfigurator = page "Add an Amazon repository" (Just Configuration)
|
2012-11-24 20:30:15 +00:00
|
|
|
|
|
|
|
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
|
|
|
|
, datacenter :: Text
|
|
|
|
-- Only used for S3, not Glacier.
|
|
|
|
, storageClass :: StorageClass
|
|
|
|
, repoName :: Text
|
2012-12-04 17:28:22 +00:00
|
|
|
, enableEncryption :: EnableEncryption
|
2012-11-24 20:30:15 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
data AWSCreds = AWSCreds Text Text
|
|
|
|
|
|
|
|
extractCreds :: AWSInput -> AWSCreds
|
|
|
|
extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i)
|
|
|
|
|
|
|
|
s3InputAForm :: AForm WebApp WebApp AWSInput
|
|
|
|
s3InputAForm = AWSInput
|
2013-04-25 16:23:36 +00:00
|
|
|
<$> accessKeyIDFieldWithHelp
|
2012-12-03 02:33:30 +00:00
|
|
|
<*> secretAccessKeyField
|
|
|
|
<*> datacenterField AWS.S3
|
2012-11-24 20:30:15 +00:00
|
|
|
<*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy)
|
|
|
|
<*> areq textField "Repository name" (Just "S3")
|
2012-12-04 17:28:22 +00:00
|
|
|
<*> enableEncryptionField
|
2012-11-24 20:30:15 +00:00
|
|
|
where
|
|
|
|
storageclasses :: [(Text, StorageClass)]
|
|
|
|
storageclasses =
|
|
|
|
[ ("Standard redundancy", StandardRedundancy)
|
|
|
|
, ("Reduced redundancy (costs less)", ReducedRedundancy)
|
|
|
|
]
|
|
|
|
|
|
|
|
glacierInputAForm :: AForm WebApp WebApp AWSInput
|
|
|
|
glacierInputAForm = AWSInput
|
2013-04-25 16:23:36 +00:00
|
|
|
<$> accessKeyIDFieldWithHelp
|
2012-12-03 02:33:30 +00:00
|
|
|
<*> secretAccessKeyField
|
|
|
|
<*> datacenterField AWS.Glacier
|
2012-11-24 20:30:15 +00:00
|
|
|
<*> pure StandardRedundancy
|
|
|
|
<*> areq textField "Repository name" (Just "glacier")
|
2012-12-04 17:28:22 +00:00
|
|
|
<*> enableEncryptionField
|
2012-11-24 20:30:15 +00:00
|
|
|
|
|
|
|
awsCredsAForm :: AForm WebApp WebApp AWSCreds
|
|
|
|
awsCredsAForm = AWSCreds
|
2013-04-25 16:23:36 +00:00
|
|
|
<$> accessKeyIDFieldWithHelp
|
2012-12-03 02:33:30 +00:00
|
|
|
<*> secretAccessKeyField
|
|
|
|
|
2013-04-25 16:23:36 +00:00
|
|
|
accessKeyIDField :: Widget -> AForm WebApp WebApp Text
|
|
|
|
accessKeyIDField help = areq (textField `withNote` help) "Access Key ID" Nothing
|
|
|
|
|
|
|
|
accessKeyIDFieldWithHelp :: AForm WebApp WebApp Text
|
|
|
|
accessKeyIDFieldWithHelp = accessKeyIDField help
|
2012-12-03 02:33:30 +00:00
|
|
|
where
|
|
|
|
help = [whamlet|
|
|
|
|
<a href="https://portal.aws.amazon.com/gp/aws/securityCredentials#id_block">
|
|
|
|
Get Amazon access keys
|
|
|
|
|]
|
|
|
|
|
|
|
|
secretAccessKeyField :: AForm WebApp WebApp Text
|
|
|
|
secretAccessKeyField = areq passwordField "Secret Access Key" Nothing
|
|
|
|
|
|
|
|
datacenterField :: AWS.Service -> AForm WebApp WebApp Text
|
|
|
|
datacenterField service = areq (selectFieldList list) "Datacenter" defregion
|
|
|
|
where
|
|
|
|
list = M.toList $ AWS.regionMap service
|
|
|
|
defregion = Just $ AWS.defaultRegion service
|
2012-11-24 20:30:15 +00:00
|
|
|
|
|
|
|
getAddS3R :: Handler RepHtml
|
2013-03-16 22:48:23 +00:00
|
|
|
getAddS3R = postAddS3R
|
|
|
|
|
|
|
|
postAddS3R :: Handler RepHtml
|
2012-11-24 20:30:15 +00:00
|
|
|
#ifdef WITH_S3
|
2013-03-16 22:48:23 +00:00
|
|
|
postAddS3R = awsConfigurator $ do
|
2012-11-24 20:30:15 +00:00
|
|
|
((result, form), enctype) <- lift $
|
2013-03-16 22:48:23 +00:00
|
|
|
runFormPost $ renderBootstrap s3InputAForm
|
2012-11-24 20:30:15 +00:00
|
|
|
case result of
|
|
|
|
FormSuccess input -> lift $ do
|
|
|
|
let name = T.unpack $ repoName input
|
|
|
|
makeAWSRemote S3.remote (extractCreds input) name setgroup $ M.fromList
|
2012-12-04 17:28:22 +00:00
|
|
|
[ configureEncryption $ enableEncryption input
|
2012-11-24 20:30:15 +00:00
|
|
|
, ("type", "S3")
|
|
|
|
, ("datacenter", T.unpack $ datacenter input)
|
|
|
|
, ("storageclass", show $ storageClass input)
|
|
|
|
]
|
2012-11-25 04:38:11 +00:00
|
|
|
_ -> $(widgetFile "configurators/adds3")
|
2012-11-24 20:30:15 +00:00
|
|
|
where
|
2013-03-04 20:36:38 +00:00
|
|
|
setgroup r = liftAnnex $
|
2012-11-24 20:30:15 +00:00
|
|
|
setStandardGroup (Remote.uuid r) TransferGroup
|
|
|
|
#else
|
2013-03-16 22:48:23 +00:00
|
|
|
postAddS3R = error "S3 not supported by this build"
|
2012-11-24 20:30:15 +00:00
|
|
|
#endif
|
|
|
|
|
|
|
|
getAddGlacierR :: Handler RepHtml
|
2013-03-16 22:48:23 +00:00
|
|
|
getAddGlacierR = postAddGlacierR
|
|
|
|
|
|
|
|
postAddGlacierR :: Handler RepHtml
|
|
|
|
postAddGlacierR = glacierConfigurator $ do
|
2012-11-24 20:30:15 +00:00
|
|
|
((result, form), enctype) <- lift $
|
2013-03-16 22:48:23 +00:00
|
|
|
runFormPost $ renderBootstrap glacierInputAForm
|
2012-11-24 20:30:15 +00:00
|
|
|
case result of
|
|
|
|
FormSuccess input -> lift $ do
|
|
|
|
let name = T.unpack $ repoName input
|
|
|
|
makeAWSRemote Glacier.remote (extractCreds input) name setgroup $ M.fromList
|
2012-12-04 17:28:22 +00:00
|
|
|
[ configureEncryption $ enableEncryption input
|
2012-11-24 20:30:15 +00:00
|
|
|
, ("type", "glacier")
|
|
|
|
, ("datacenter", T.unpack $ datacenter input)
|
|
|
|
]
|
2012-11-25 04:38:11 +00:00
|
|
|
_ -> $(widgetFile "configurators/addglacier")
|
2012-11-24 20:30:15 +00:00
|
|
|
where
|
2013-03-16 04:12:28 +00:00
|
|
|
setgroup r = liftAnnex $
|
2012-11-24 20:30:15 +00:00
|
|
|
setStandardGroup (Remote.uuid r) SmallArchiveGroup
|
|
|
|
|
|
|
|
getEnableS3R :: UUID -> Handler RepHtml
|
2013-04-26 20:07:55 +00:00
|
|
|
#ifdef WITH_S3
|
2013-04-25 17:14:49 +00:00
|
|
|
getEnableS3R uuid = do
|
|
|
|
m <- liftAnnex readRemoteLog
|
|
|
|
let host = fromMaybe "" $ M.lookup "host" $
|
|
|
|
fromJust $ M.lookup uuid m
|
|
|
|
if S3.isIAHost host
|
|
|
|
then redirect $ EnableIAR uuid
|
|
|
|
else postEnableS3R uuid
|
2013-04-26 20:07:55 +00:00
|
|
|
#else
|
|
|
|
getEnableS3R = postEnableS3R
|
|
|
|
#endif
|
2013-03-16 22:48:23 +00:00
|
|
|
|
|
|
|
postEnableS3R :: UUID -> Handler RepHtml
|
2012-11-24 20:30:15 +00:00
|
|
|
#ifdef WITH_S3
|
2013-04-25 17:14:49 +00:00
|
|
|
postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid
|
2012-11-24 20:30:15 +00:00
|
|
|
#else
|
2013-03-16 22:48:23 +00:00
|
|
|
postEnableS3R _ = error "S3 not supported by this build"
|
2012-11-24 20:30:15 +00:00
|
|
|
#endif
|
|
|
|
|
|
|
|
getEnableGlacierR :: UUID -> Handler RepHtml
|
2013-03-16 22:48:23 +00:00
|
|
|
getEnableGlacierR = postEnableGlacierR
|
|
|
|
|
|
|
|
postEnableGlacierR :: UUID -> Handler RepHtml
|
|
|
|
postEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote
|
2012-11-24 20:30:15 +00:00
|
|
|
|
|
|
|
enableAWSRemote :: RemoteType -> UUID -> Widget
|
|
|
|
enableAWSRemote remotetype uuid = do
|
|
|
|
((result, form), enctype) <- lift $
|
2013-03-16 22:48:23 +00:00
|
|
|
runFormPost $ renderBootstrap awsCredsAForm
|
2012-11-24 20:30:15 +00:00
|
|
|
case result of
|
|
|
|
FormSuccess creds -> lift $ do
|
2013-03-04 20:36:38 +00:00
|
|
|
m <- liftAnnex readRemoteLog
|
2012-11-24 20:30:15 +00:00
|
|
|
let name = fromJust $ M.lookup "name" $
|
|
|
|
fromJust $ M.lookup uuid m
|
|
|
|
makeAWSRemote remotetype creds name (const noop) M.empty
|
|
|
|
_ -> do
|
2013-03-16 04:12:28 +00:00
|
|
|
description <- liftAnnex $
|
2013-04-03 21:01:40 +00:00
|
|
|
T.pack <$> Remote.prettyUUID uuid
|
2012-11-24 20:30:15 +00:00
|
|
|
$(widgetFile "configurators/enableaws")
|
|
|
|
|
|
|
|
makeAWSRemote :: RemoteType -> AWSCreds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
|
|
|
|
makeAWSRemote remotetype (AWSCreds ak sk) name setup config = do
|
2013-03-04 20:36:38 +00:00
|
|
|
remotename <- liftAnnex $ fromRepo $ uniqueRemoteName name 0
|
2012-11-24 20:30:15 +00:00
|
|
|
liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)
|
2013-03-04 20:36:38 +00:00
|
|
|
r <- liftAnnex $ addRemote $ do
|
2013-01-14 16:54:29 +00:00
|
|
|
makeSpecialRemote hostname remotetype config
|
2012-11-24 20:30:15 +00:00
|
|
|
return remotename
|
|
|
|
setup r
|
2013-04-08 19:36:09 +00:00
|
|
|
liftAssistant $ syncRemote r
|
2012-11-24 20:30:15 +00:00
|
|
|
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
|
2013-01-14 16:54:29 +00:00
|
|
|
where
|
|
|
|
{- AWS services use the remote name as the basis for a host
|
|
|
|
- name, so filter it to contain valid characters. -}
|
|
|
|
hostname = case filter isAlphaNum name of
|
|
|
|
[] -> "aws"
|
|
|
|
n -> n
|
2013-04-25 20:42:17 +00:00
|
|
|
|
|
|
|
getRepoInfo :: RemoteConfig -> Widget
|
|
|
|
getRepoInfo c = [whamlet|S3 remote using bucket: #{bucket}|]
|
|
|
|
where
|
|
|
|
bucket = fromMaybe "" $ M.lookup "bucket" c
|