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