1{- git-annex assistant webapp configurators for Amazon AWS services
2 -
3 - Copyright 2012 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
9
10module Assistant.WebApp.Configurators.AWS where
11
12import Assistant.WebApp.Common
13import Assistant.WebApp.MakeRemote
14import qualified Remote.S3 as S3
15import Logs.Remote
16import qualified Remote
17import qualified Types.Remote as Remote
18import qualified Remote.Glacier as Glacier
19import qualified Remote.Helper.AWS as AWS
20import Types.Remote (RemoteConfig)
21import Types.StandardGroups
22import Creds
23import Assistant.Gpg
24import Git.Types (RemoteName)
25import Annex.SpecialRemote.Config
26import Types.ProposedAccepted
27
28import qualified Data.Text as T
29import qualified Data.Map as M
30import Data.Char
31
32awsConfigurator :: Widget -> Handler Html
33awsConfigurator = page "Add an Amazon repository" (Just Configuration)
34
35glacierConfigurator :: Widget -> Handler Html
36glacierConfigurator a = do
37	ifM (liftIO $ inSearchPath "glacier")
38		( awsConfigurator a
39		, awsConfigurator needglaciercli
40		)
41  where
42	needglaciercli = $(widgetFile "configurators/needglaciercli")
43
44data StorageClass
45	= StandardRedundancy
46	| StandardInfrequentAccess
47	deriving (Eq, Enum, Bounded)
48
49instance Show StorageClass where
50	show StandardRedundancy = "STANDARD"
51	show StandardInfrequentAccess = "STANDARD_IA"
52
53data AWSInput = AWSInput
54	{ accessKeyID :: Text
55	, secretAccessKey :: Text
56	, datacenter :: Text
57	-- Only used for S3, not Glacier.
58	, storageClass :: StorageClass
59	, repoName :: Text
60	, enableEncryption :: EnableEncryption
61	}
62
63data AWSCreds = AWSCreds Text Text
64
65extractCreds :: AWSInput -> AWSCreds
66extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i)
67
68s3InputAForm :: Maybe CredPair -> MkAForm AWSInput
69s3InputAForm defcreds = AWSInput
70	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
71	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
72	<*> datacenterField AWS.S3
73	<*> areq (selectFieldList storageclasses) (bfs "Storage class") (Just StandardRedundancy)
74	<*> areq textField (bfs "Repository name") (Just "S3")
75	<*> enableEncryptionField
76  where
77	storageclasses :: [(Text, StorageClass)]
78	storageclasses =
79		[ ("Standard redundancy", StandardRedundancy)
80		, ("Infrequent access (cheaper for backups and archives)", StandardInfrequentAccess)
81		]
82
83glacierInputAForm :: Maybe CredPair -> MkAForm AWSInput
84glacierInputAForm defcreds = AWSInput
85	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
86	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
87	<*> datacenterField AWS.Glacier
88	<*> pure StandardRedundancy
89	<*> areq textField (bfs "Repository name") (Just "glacier")
90	<*> enableEncryptionField
91
92awsCredsAForm :: Maybe CredPair -> MkAForm AWSCreds
93awsCredsAForm defcreds = AWSCreds
94	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
95	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
96
97accessKeyIDField :: Widget -> Maybe Text -> MkAForm Text
98accessKeyIDField help = areq (textField `withNote` help) (bfs "Access Key ID")
99
100accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text
101accessKeyIDFieldWithHelp = accessKeyIDField help
102  where
103	help = [whamlet|
104<a href="https://portal.aws.amazon.com/gp/aws/securityCredentials#id_block">
105  Get Amazon access keys
106|]
107
108secretAccessKeyField :: Maybe Text -> MkAForm Text
109secretAccessKeyField = areq passwordField (bfs "Secret Access Key")
110
111datacenterField :: AWS.Service -> MkAForm Text
112datacenterField service = areq (selectFieldList list) (bfs "Datacenter") defregion
113  where
114	list = M.toList $ AWS.regionMap service
115	defregion = Just $ AWS.defaultRegion service
116
117getAddS3R :: Handler Html
118getAddS3R = postAddS3R
119
120postAddS3R :: Handler Html
121postAddS3R = awsConfigurator $ do
122	defcreds <- liftAnnex previouslyUsedAWSCreds
123	((result, form), enctype) <- liftH $
124		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ s3InputAForm defcreds
125	case result of
126		FormSuccess input -> liftH $ do
127			let name = T.unpack $ repoName input
128			makeAWSRemote initSpecialRemote S3.remote TransferGroup (extractCreds input) name $ M.fromList
129				[ configureEncryption $ enableEncryption input
130				, (typeField, Proposed "S3")
131				, (Proposed "datacenter", Proposed $ T.unpack $ datacenter input)
132				, (Proposed "storageclass", Proposed $ show $ storageClass input)
133				, (Proposed "chunk", Proposed "1MiB")
134				]
135		_ -> $(widgetFile "configurators/adds3")
136
137getAddGlacierR :: Handler Html
138getAddGlacierR = postAddGlacierR
139
140postAddGlacierR :: Handler Html
141postAddGlacierR = glacierConfigurator $ do
142	defcreds <- liftAnnex previouslyUsedAWSCreds
143	((result, form), enctype) <- liftH $
144		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ glacierInputAForm defcreds
145	case result of
146		FormSuccess input -> liftH $ do
147			let name = T.unpack $ repoName input
148			makeAWSRemote initSpecialRemote Glacier.remote SmallArchiveGroup (extractCreds input) name $ M.fromList
149				[ configureEncryption $ enableEncryption input
150				, (typeField, Proposed "glacier")
151				, (Proposed "datacenter", Proposed $ T.unpack $ datacenter input)
152				]
153		_ -> $(widgetFile "configurators/addglacier")
154
155getEnableS3R :: UUID -> Handler Html
156getEnableS3R uuid = do
157	m <- liftAnnex remoteConfigMap
158	isia <- case M.lookup uuid m of
159		Just c -> liftAnnex $ do
160			pc <- parsedRemoteConfig S3.remote c
161			return $ S3.configIA pc
162		Nothing -> return False
163	if isia
164		then redirect $ EnableIAR uuid
165		else postEnableS3R uuid
166
167postEnableS3R :: UUID -> Handler Html
168postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid
169
170getEnableGlacierR :: UUID -> Handler Html
171getEnableGlacierR = postEnableGlacierR
172
173postEnableGlacierR :: UUID -> Handler Html
174postEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote
175
176enableAWSRemote :: RemoteType -> UUID -> Widget
177enableAWSRemote remotetype uuid = do
178	defcreds <- liftAnnex previouslyUsedAWSCreds
179	((result, form), enctype) <- liftH $
180		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ awsCredsAForm defcreds
181	case result of
182		FormSuccess creds -> liftH $ do
183			m <- liftAnnex remoteConfigMap
184			let name = fromJust $ lookupName $
185				fromJust $ M.lookup uuid m
186			makeAWSRemote enableSpecialRemote remotetype SmallArchiveGroup creds name M.empty
187		_ -> do
188			description <- liftAnnex $
189				T.pack <$> Remote.prettyUUID uuid
190			$(widgetFile "configurators/enableaws")
191
192makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> StandardGroup -> AWSCreds -> RemoteName -> RemoteConfig -> Handler ()
193makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config =
194	setupCloudRemote defaultgroup Nothing $
195		maker hostname remotetype (Just creds) config
196  where
197	creds = (T.unpack ak, T.unpack sk)
198	{- AWS services use the remote name as the basis for a host
199	 - name, so filter it to contain valid characters. -}
200	hostname = case filter isAlphaNum name of
201		[] -> "aws"
202		n -> n
203
204getRepoInfo :: RemoteConfig -> Widget
205getRepoInfo c = [whamlet|S3 remote using bucket: #{bucket}|]
206  where
207	bucket = maybe "" fromProposedAccepted $ M.lookup (Accepted "bucket") c
208
209previouslyUsedAWSCreds :: Annex (Maybe CredPair)
210previouslyUsedAWSCreds = getM gettype [S3.remote, Glacier.remote]
211  where
212	gettype t = previouslyUsedCredPair AWS.creds t $
213		not . S3.configIA . Remote.config
214