webapp: Now automatically fills in any creds used by an existing remote when creating a new remote of the same type. Done for Internet Archive, S3, Glacier, and Box.com remotes.

2013-04-27 15:16:06 -04:00 · 2013-04-27 15:16:06 -04:00 · c3498042fd
commit c3498042fd
parent 8626e67e97
6 changed files with 122 additions and 50 deletions
--- a/Assistant/MakeRemote.hs
+++ b/Assistant/MakeRemote.hs
@ -1,6 +1,6 @@
 {- git-annex assistant remote creation utilities
 -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
@ -22,6 +22,7 @@ import Logs.Remote
 import Git.Remote
 import Config
 import Config.Cost
+import Creds

 import qualified Data.Text as T
 import qualified Data.Map as M
@ -125,3 +126,25 @@ uniqueRemoteName basename n r
 		| n == 0 = legalbasename
 		| otherwise = legalbasename ++ show n
 	legalbasename = makeLegalName basename
+
+{- Finds a CredPair belonging to any Remote that is of a given type
+ - and matches some other criteria.
+ -
+ - This can be used as a default when another repository is being set up
+ - using the same service.
+ -
+ - A function must be provided that returns the CredPairStorage
+ - to use for a particular Remote's uuid.
+ -}
+previouslyUsedCredPair
+	:: (UUID -> CredPairStorage)
+	-> RemoteType
+	-> (Remote -> Bool)
+	-> Annex (Maybe CredPair)
+previouslyUsedCredPair getstorage remotetype criteria =
+	getM fromstorage =<< filter criteria . filter sametype <$> remoteList
+  where
+	sametype r = R.typename (R.remotetype r) == R.typename remotetype
+	fromstorage r = do
+		let storage = getstorage (R.uuid r)
+		getRemoteCredPair (R.config r) storage
--- a/Assistant/WebApp/Configurators/AWS.hs
+++ b/Assistant/WebApp/Configurators/AWS.hs
@ -19,9 +19,11 @@ 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 Logs.PreferredContent
+import Creds

 import qualified Data.Text as T
 import qualified Data.Map as M
@ -61,10 +63,10 @@ data AWSCreds = AWSCreds Text Text
 extractCreds :: AWSInput -> AWSCreds
 extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i)

-s3InputAForm :: AForm WebApp WebApp AWSInput
-s3InputAForm = AWSInput
-	<$> accessKeyIDFieldWithHelp
-	<*> secretAccessKeyField
+s3InputAForm :: Maybe CredPair -> AForm WebApp WebApp AWSInput
+s3InputAForm defcreds = AWSInput
+	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
+	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
 	<*> datacenterField AWS.S3
 	<*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy)
 	<*> areq textField "Repository name" (Just "S3")
@ -76,33 +78,33 @@ s3InputAForm = AWSInput
 		, ("Reduced redundancy (costs less)", ReducedRedundancy)
 		]

-glacierInputAForm :: AForm WebApp WebApp AWSInput
-glacierInputAForm = AWSInput
-	<$> accessKeyIDFieldWithHelp
-	<*> secretAccessKeyField
+glacierInputAForm :: Maybe CredPair -> AForm WebApp WebApp AWSInput
+glacierInputAForm defcreds = AWSInput
+	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
+	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
 	<*> datacenterField AWS.Glacier
 	<*> pure StandardRedundancy
 	<*> areq textField "Repository name" (Just "glacier")
 	<*> enableEncryptionField

-awsCredsAForm :: AForm WebApp WebApp AWSCreds
-awsCredsAForm = AWSCreds
-	<$> accessKeyIDFieldWithHelp
-	<*> secretAccessKeyField
+awsCredsAForm :: Maybe CredPair -> AForm WebApp WebApp AWSCreds
+awsCredsAForm defcreds = AWSCreds
+	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
+	<*> secretAccessKeyField (T.pack . snd <$> defcreds)

-accessKeyIDField :: Widget -> AForm WebApp WebApp Text
-accessKeyIDField help = areq (textField `withNote` help) "Access Key ID" Nothing
+accessKeyIDField :: Widget -> Maybe Text -> AForm WebApp WebApp Text
+accessKeyIDField help def = areq (textField `withNote` help) "Access Key ID" def

-accessKeyIDFieldWithHelp :: AForm WebApp WebApp Text
-accessKeyIDFieldWithHelp = accessKeyIDField help
+accessKeyIDFieldWithHelp :: Maybe Text -> AForm WebApp WebApp Text
+accessKeyIDFieldWithHelp def = accessKeyIDField help def
  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
+secretAccessKeyField :: Maybe Text -> AForm WebApp WebApp Text
+secretAccessKeyField def = areq passwordField "Secret Access Key" def

 datacenterField :: AWS.Service -> AForm WebApp WebApp Text
 datacenterField service = areq (selectFieldList list) "Datacenter" defregion
@ -116,8 +118,9 @@ getAddS3R = postAddS3R
 postAddS3R :: Handler RepHtml
 #ifdef WITH_S3
 postAddS3R = awsConfigurator $ do
+	defcreds <- liftAnnex previouslyUsedAWSCreds
 	((result, form), enctype) <- lift $
-		runFormPost $ renderBootstrap s3InputAForm
+		runFormPost $ renderBootstrap $ s3InputAForm defcreds
 	case result of
 		FormSuccess input -> lift $ do
 			let name = T.unpack $ repoName input
@ -140,8 +143,9 @@ getAddGlacierR = postAddGlacierR

 postAddGlacierR :: Handler RepHtml
 postAddGlacierR = glacierConfigurator $ do
+	defcreds <- liftAnnex previouslyUsedAWSCreds
 	((result, form), enctype) <- lift $
-		runFormPost $ renderBootstrap glacierInputAForm
+		runFormPost $ renderBootstrap $ glacierInputAForm defcreds
 	case result of
 		FormSuccess input -> lift $ do
 			let name = T.unpack $ repoName input
@ -159,9 +163,7 @@ getEnableS3R :: UUID -> Handler RepHtml
 #ifdef WITH_S3
 getEnableS3R uuid = do
 	m <- liftAnnex readRemoteLog
-	let host = fromMaybe "" $ M.lookup "host" $
-		fromJust $ M.lookup uuid m
-	if S3.isIAHost host
+	if isIARemoteConfig $ fromJust $ M.lookup uuid m
 		then redirect $ EnableIAR uuid
 		else postEnableS3R uuid
 #else
@ -183,8 +185,9 @@ postEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote

 enableAWSRemote :: RemoteType -> UUID -> Widget
 enableAWSRemote remotetype uuid = do
+	defcreds <- liftAnnex previouslyUsedAWSCreds
 	((result, form), enctype) <- lift $
-		runFormPost $ renderBootstrap awsCredsAForm
+		runFormPost $ renderBootstrap $ awsCredsAForm defcreds
 	case result of
 		FormSuccess creds -> lift $ do
 			m <- liftAnnex readRemoteLog
@ -217,3 +220,14 @@ getRepoInfo :: RemoteConfig -> Widget
 getRepoInfo c = [whamlet|S3 remote using bucket: #{bucket}|]
  where
 	bucket = fromMaybe "" $ M.lookup "bucket" c
+
+#ifdef WITH_S3
+isIARemoteConfig :: RemoteConfig -> Bool
+isIARemoteConfig = S3.isIAHost . fromMaybe "" . M.lookup "host"
+#endif
+
+previouslyUsedAWSCreds :: Annex (Maybe CredPair)
+previouslyUsedAWSCreds = getM gettype [S3.remote, Glacier.remote]
+  where
+	gettype t = previouslyUsedCredPair AWS.creds t $
+		not . isIARemoteConfig . Remote.config
--- a/Assistant/WebApp/Configurators/IA.hs
+++ b/Assistant/WebApp/Configurators/IA.hs
@ -13,13 +13,17 @@ import Assistant.WebApp.Common
 import qualified Assistant.WebApp.Configurators.AWS as AWS
 #ifdef WITH_S3
 import qualified Remote.S3 as S3
+import qualified Remote.Helper.AWS as AWS
+import Assistant.MakeRemote
 #endif
 import qualified Remote
+import qualified Types.Remote as Remote
 import Types.StandardGroups
 import Types.Remote (RemoteConfig)
 import Logs.PreferredContent
 import Logs.Remote
 import qualified Utility.Url as Url
+import Creds

 import qualified Data.Text as T
 import qualified Data.Map as M
@ -75,10 +79,10 @@ showMediaType MediaVideo = "videos & movies"
 showMediaType MediaAudio = "audio & music"
 showMediaType MediaOmitted = "other"

-iaInputAForm :: AForm WebApp WebApp IAInput
-iaInputAForm = IAInput
-	<$> accessKeyIDFieldWithHelp
-	<*> AWS.secretAccessKeyField
+iaInputAForm :: Maybe CredPair -> AForm WebApp WebApp IAInput
+iaInputAForm defcreds = IAInput
+	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
+	<*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
 	<*> areq (selectFieldList mediatypes) "Media Type" (Just MediaOmitted)
 	<*> areq (textField `withExpandableNote` ("Help", itemNameHelp)) "Item Name" Nothing
  where
@ -95,13 +99,19 @@ itemNameHelp = [whamlet|
  will be uploaded to your Internet Archive item.
 |]

-iaCredsAForm :: AForm WebApp WebApp AWS.AWSCreds
-iaCredsAForm = AWS.AWSCreds
-        <$> accessKeyIDFieldWithHelp
-        <*> AWS.secretAccessKeyField
+iaCredsAForm :: Maybe CredPair -> AForm WebApp WebApp AWS.AWSCreds
+iaCredsAForm defcreds = AWS.AWSCreds
+        <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
+        <*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)

-accessKeyIDFieldWithHelp :: AForm WebApp WebApp Text
-accessKeyIDFieldWithHelp = AWS.accessKeyIDField help
+#ifdef WITH_S3
+previouslyUsedIACreds :: Annex (Maybe CredPair)
+previouslyUsedIACreds = previouslyUsedCredPair AWS.creds S3.remote $
+	AWS.isIARemoteConfig . Remote.config
+#endif
+
+accessKeyIDFieldWithHelp :: Maybe Text -> AForm WebApp WebApp Text
+accessKeyIDFieldWithHelp def = AWS.accessKeyIDField help def
  where
 	help = [whamlet|
 <a href="http://archive.org/account/s3.php">
@ -114,8 +124,9 @@ getAddIAR = postAddIAR
 postAddIAR :: Handler RepHtml
 #ifdef WITH_S3
 postAddIAR = iaConfigurator $ do
+	defcreds <- liftAnnex previouslyUsedIACreds
 	((result, form), enctype) <- lift $
-		runFormPost $ renderBootstrap iaInputAForm
+		runFormPost $ renderBootstrap $ iaInputAForm defcreds
 	case result of
 		FormSuccess input -> lift $ do
 			let name = escapeBucket $ T.unpack $ itemName input
@ -155,8 +166,9 @@ postEnableIAR _ = error "S3 not supported by this build"
 #ifdef WITH_S3
 enableIARemote :: UUID -> Widget
 enableIARemote uuid = do
+	defcreds <- liftAnnex previouslyUsedIACreds
 	((result, form), enctype) <- lift $
-		runFormPost $ renderBootstrap iaCredsAForm
+		runFormPost $ renderBootstrap $ iaCredsAForm defcreds
 	case result of
 		FormSuccess creds -> lift $ do
 			m <- liftAnnex readRemoteLog
--- a/Assistant/WebApp/Configurators/WebDAV.hs
+++ b/Assistant/WebApp/Configurators/WebDAV.hs
@ -1,6 +1,6 @@
 {- git-annex assistant webapp configurators for WebDAV remotes
 -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}
@ -24,6 +24,7 @@ import Logs.Remote
 import qualified Data.Map as M
 #endif
 import qualified Data.Text as T
+import Network.URI

 webDAVConfigurator :: Widget -> Handler RepHtml
 webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration)
@ -42,18 +43,18 @@ data WebDAVInput = WebDAVInput
 toCredPair :: WebDAVInput -> CredPair
 toCredPair input = (T.unpack $ user input, T.unpack $ password input)

-boxComAForm :: AForm WebApp WebApp WebDAVInput
-boxComAForm = WebDAVInput
-	<$> areq textField "Username or Email" Nothing
-	<*> areq passwordField "Box.com Password" Nothing
+boxComAForm :: Maybe CredPair -> AForm WebApp WebApp WebDAVInput
+boxComAForm defcreds = WebDAVInput
+	<$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
+	<*> areq passwordField "Box.com Password" (T.pack . snd <$> defcreds)
 	<*> areq checkBoxField "Share this account with other devices and friends?" (Just True)
 	<*> areq textField "Directory" (Just "annex")
 	<*> enableEncryptionField

-webDAVCredsAForm :: AForm WebApp WebApp WebDAVInput
-webDAVCredsAForm = WebDAVInput
-	<$> areq textField "Username or Email" Nothing
-	<*> areq passwordField "Password" Nothing
+webDAVCredsAForm :: Maybe CredPair -> AForm WebApp WebApp WebDAVInput
+webDAVCredsAForm defcreds = WebDAVInput
+	<$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
+	<*> areq passwordField "Password" (T.pack . snd <$> defcreds)
 	<*> pure False
 	<*> pure T.empty
 	<*> pure NoEncryption -- not used!
@ -63,8 +64,9 @@ getAddBoxComR = postAddBoxComR
 postAddBoxComR :: Handler RepHtml
 #ifdef WITH_WEBDAV
 postAddBoxComR = boxConfigurator $ do
+	defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"
 	((result, form), enctype) <- lift $
-		runFormPost $ renderBootstrap boxComAForm
+		runFormPost $ renderBootstrap $ boxComAForm defcreds
 	case result of
 		FormSuccess input -> lift $ 
 			makeWebDavRemote "box.com" (toCredPair input) setgroup $ M.fromList
@ -106,8 +108,11 @@ postEnableWebDAVR uuid = do
 				webDAVConfigurator $ showform name url
  where
 	showform name url = do
+		defcreds <- liftAnnex $ 
+			maybe (pure Nothing) previouslyUsedWebDAVCreds $
+				urlHost url
 		((result, form), enctype) <- lift $
-			runFormPost $ renderBootstrap webDAVCredsAForm
+			runFormPost $ renderBootstrap $ webDAVCredsAForm defcreds
 		case result of
 			FormSuccess input -> lift $
 				makeWebDavRemote name (toCredPair input) (const noop) M.empty
@ -131,3 +136,15 @@ makeWebDavRemote name creds setup config = do
 	liftAssistant $ syncRemote r
 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r
 #endif
+
+{- Only returns creds previously used for the same hostname. -}
+previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair)
+previouslyUsedWebDAVCreds hostname =
+	previouslyUsedCredPair WebDAV.davCreds WebDAV.remote samehost
+  where
+	samehost url = case urlHost =<< WebDAV.configUrl url of
+		Nothing -> False
+		Just h -> h == hostname
+
+urlHost :: String -> Maybe String
+urlHost url = uriRegName <$> (uriAuthority =<< parseURI url)
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@ -7,7 +7,7 @@

 {-# LANGUAGE ScopedTypeVariables, CPP #-}

-module Remote.WebDAV (remote, davCreds, setCredsEnv) where
+module Remote.WebDAV (remote, davCreds, setCredsEnv, configUrl) where

 import Network.Protocol.HTTP.DAV
 import qualified Data.Map as M
@ -203,11 +203,14 @@ withStoredFiles r k baseurl user pass onerr a
 davAction :: Remote -> a -> ((DavUrl, DavUser, DavPass) -> Annex a) -> Annex a
 davAction r unconfigured action = do
 	mcreds <- getCreds (config r) (uuid r)
-	case (mcreds, M.lookup "url" $ config r) of
+	case (mcreds, configUrl r) of
 		(Just (user, pass), Just url) ->
 			action (url, toDavUser user, toDavPass pass)
 		_ -> return unconfigured

+configUrl :: Remote -> Maybe DavUrl
+configUrl r = M.lookup "url" $ config r
+
 toDavUser :: String -> DavUser
 toDavUser = B8.fromString

--- a/debian/changelog
+++ b/debian/changelog
@ -43,6 +43,9 @@ git-annex (4.20130418) UNRELEASED; urgency=low
  * To enable an existing special remote, the new enableremote command
    must be used. The initremote command now is used only to create
    new special remotes.
+  * webapp: Now automatically fills in any creds used by an existing remote
+    when creating a new remote of the same type. Done for Internet Archive,
+    S3, Glacier, and Box.com remotes.

 -- Joey Hess <joeyh@debian.org>  Thu, 18 Apr 2013 16:22:48 -0400