webapp and assistant glacier support

Assistant/WebApp/Configurators/AWS.hs

@@ -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