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