mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

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.

Browse source
This commit is contained in:
Joey Hess 2013-04-27 15:16:06 -04:00
parent 8626e67e97
commit c3498042fd
6 changed files with 122 additions and 50 deletions
Download patch file Download diff file Expand all files Collapse all files

25
Assistant/MakeRemote.hs
View file

@ -1,6 +1,6 @@
{- git-annex assistant remote creation utilities {- 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. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -22,6 +22,7 @@ import Logs.Remote
import Git.Remote import Git.Remote
import Config import Config
import Config.Cost import Config.Cost
import Creds
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
@ -125,3 +126,25 @@ uniqueRemoteName basename n r
| n == 0 = legalbasename | n == 0 = legalbasename
| otherwise = legalbasename ++ show n | otherwise = legalbasename ++ show n
legalbasename = makeLegalName basename 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

62
Assistant/WebApp/Configurators/AWS.hs
View file

@ -19,9 +19,11 @@ import qualified Remote.Glacier as Glacier
import qualified Remote.Helper.AWS as AWS import qualified Remote.Helper.AWS as AWS
import Logs.Remote import Logs.Remote
import qualified Remote import qualified Remote
import qualified Types.Remote as Remote
import Types.Remote (RemoteConfig) import Types.Remote (RemoteConfig)
import Types.StandardGroups import Types.StandardGroups
import Logs.PreferredContent import Logs.PreferredContent
import Creds
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
@ -61,10 +63,10 @@ data AWSCreds = AWSCreds Text Text
extractCreds :: AWSInput -> AWSCreds extractCreds :: AWSInput -> AWSCreds
extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i) extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i)
s3InputAForm :: AForm WebApp WebApp AWSInput s3InputAForm :: Maybe CredPair -> AForm WebApp WebApp AWSInput
s3InputAForm = AWSInput s3InputAForm defcreds = AWSInput
<$> accessKeyIDFieldWithHelp <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> secretAccessKeyField <*> secretAccessKeyField (T.pack . snd <$> defcreds)
<*> datacenterField AWS.S3 <*> datacenterField AWS.S3
<*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy) <*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy)
<*> areq textField "Repository name" (Just "S3") <*> areq textField "Repository name" (Just "S3")
@ -76,33 +78,33 @@ s3InputAForm = AWSInput
, ("Reduced redundancy (costs less)", ReducedRedundancy) , ("Reduced redundancy (costs less)", ReducedRedundancy)
] ]
glacierInputAForm :: AForm WebApp WebApp AWSInput glacierInputAForm :: Maybe CredPair -> AForm WebApp WebApp AWSInput
glacierInputAForm = AWSInput glacierInputAForm defcreds = AWSInput
<$> accessKeyIDFieldWithHelp <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> secretAccessKeyField <*> secretAccessKeyField (T.pack . snd <$> defcreds)
<*> datacenterField AWS.Glacier <*> datacenterField AWS.Glacier
<*> pure StandardRedundancy <*> pure StandardRedundancy
<*> areq textField "Repository name" (Just "glacier") <*> areq textField "Repository name" (Just "glacier")
<*> enableEncryptionField <*> enableEncryptionField
awsCredsAForm :: AForm WebApp WebApp AWSCreds awsCredsAForm :: Maybe CredPair -> AForm WebApp WebApp AWSCreds
awsCredsAForm = AWSCreds awsCredsAForm defcreds = AWSCreds
<$> accessKeyIDFieldWithHelp <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> secretAccessKeyField <*> secretAccessKeyField (T.pack . snd <$> defcreds)
accessKeyIDField :: Widget -> AForm WebApp WebApp Text accessKeyIDField :: Widget -> Maybe Text -> AForm WebApp WebApp Text
accessKeyIDField help = areq (textField `withNote` help) "Access Key ID" Nothing accessKeyIDField help def = areq (textField `withNote` help) "Access Key ID" def
accessKeyIDFieldWithHelp :: AForm WebApp WebApp Text accessKeyIDFieldWithHelp :: Maybe Text -> AForm WebApp WebApp Text
accessKeyIDFieldWithHelp = accessKeyIDField help accessKeyIDFieldWithHelp def = accessKeyIDField help def
where where
help = [whamlet| help = [whamlet|
<a href="https://portal.aws.amazon.com/gp/aws/securityCredentials#id_block"> <a href="https://portal.aws.amazon.com/gp/aws/securityCredentials#id_block">
Get Amazon access keys Get Amazon access keys
|] |]
secretAccessKeyField :: AForm WebApp WebApp Text secretAccessKeyField :: Maybe Text -> AForm WebApp WebApp Text
secretAccessKeyField = areq passwordField "Secret Access Key" Nothing secretAccessKeyField def = areq passwordField "Secret Access Key" def
datacenterField :: AWS.Service -> AForm WebApp WebApp Text datacenterField :: AWS.Service -> AForm WebApp WebApp Text
datacenterField service = areq (selectFieldList list) "Datacenter" defregion datacenterField service = areq (selectFieldList list) "Datacenter" defregion
@ -116,8 +118,9 @@ getAddS3R = postAddS3R
postAddS3R :: Handler RepHtml postAddS3R :: Handler RepHtml
#ifdef WITH_S3 #ifdef WITH_S3
postAddS3R = awsConfigurator $ do postAddS3R = awsConfigurator $ do
defcreds <- liftAnnex previouslyUsedAWSCreds
((result, form), enctype) <- lift $ ((result, form), enctype) <- lift $
runFormPost $ renderBootstrap s3InputAForm runFormPost $ renderBootstrap $ s3InputAForm defcreds
case result of case result of
FormSuccess input -> lift $ do FormSuccess input -> lift $ do
let name = T.unpack $ repoName input let name = T.unpack $ repoName input
@ -140,8 +143,9 @@ getAddGlacierR = postAddGlacierR
postAddGlacierR :: Handler RepHtml postAddGlacierR :: Handler RepHtml
postAddGlacierR = glacierConfigurator $ do postAddGlacierR = glacierConfigurator $ do
defcreds <- liftAnnex previouslyUsedAWSCreds
((result, form), enctype) <- lift $ ((result, form), enctype) <- lift $
runFormPost $ renderBootstrap glacierInputAForm runFormPost $ renderBootstrap $ glacierInputAForm defcreds
case result of case result of
FormSuccess input -> lift $ do FormSuccess input -> lift $ do
let name = T.unpack $ repoName input let name = T.unpack $ repoName input
@ -159,9 +163,7 @@ getEnableS3R :: UUID -> Handler RepHtml
#ifdef WITH_S3 #ifdef WITH_S3
getEnableS3R uuid = do getEnableS3R uuid = do
m <- liftAnnex readRemoteLog m <- liftAnnex readRemoteLog
let host = fromMaybe "" $ M.lookup "host" $ if isIARemoteConfig $ fromJust $ M.lookup uuid m
fromJust $ M.lookup uuid m
if S3.isIAHost host
then redirect $ EnableIAR uuid then redirect $ EnableIAR uuid
else postEnableS3R uuid else postEnableS3R uuid
#else #else
@ -183,8 +185,9 @@ postEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote
enableAWSRemote :: RemoteType -> UUID -> Widget enableAWSRemote :: RemoteType -> UUID -> Widget
enableAWSRemote remotetype uuid = do enableAWSRemote remotetype uuid = do
defcreds <- liftAnnex previouslyUsedAWSCreds
((result, form), enctype) <- lift $ ((result, form), enctype) <- lift $
runFormPost $ renderBootstrap awsCredsAForm runFormPost $ renderBootstrap $ awsCredsAForm defcreds
case result of case result of
FormSuccess creds -> lift $ do FormSuccess creds -> lift $ do
m <- liftAnnex readRemoteLog m <- liftAnnex readRemoteLog
@ -217,3 +220,14 @@ getRepoInfo :: RemoteConfig -> Widget
getRepoInfo c = [whamlet|S3 remote using bucket: #{bucket}|] getRepoInfo c = [whamlet|S3 remote using bucket: #{bucket}|]
where where
bucket = fromMaybe "" $ M.lookup "bucket" c 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

36
Assistant/WebApp/Configurators/IA.hs
View file

@ -13,13 +13,17 @@ import Assistant.WebApp.Common
import qualified Assistant.WebApp.Configurators.AWS as AWS import qualified Assistant.WebApp.Configurators.AWS as AWS
#ifdef WITH_S3 #ifdef WITH_S3
import qualified Remote.S3 as S3 import qualified Remote.S3 as S3
import qualified Remote.Helper.AWS as AWS
import Assistant.MakeRemote
#endif #endif
import qualified Remote import qualified Remote
import qualified Types.Remote as Remote
import Types.StandardGroups import Types.StandardGroups
import Types.Remote (RemoteConfig) import Types.Remote (RemoteConfig)
import Logs.PreferredContent import Logs.PreferredContent
import Logs.Remote import Logs.Remote
import qualified Utility.Url as Url import qualified Utility.Url as Url
import Creds
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
@ -75,10 +79,10 @@ showMediaType MediaVideo = "videos & movies"
showMediaType MediaAudio = "audio & music" showMediaType MediaAudio = "audio & music"
showMediaType MediaOmitted = "other" showMediaType MediaOmitted = "other"
iaInputAForm :: AForm WebApp WebApp IAInput iaInputAForm :: Maybe CredPair -> AForm WebApp WebApp IAInput
iaInputAForm = IAInput iaInputAForm defcreds = IAInput
<$> accessKeyIDFieldWithHelp <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> AWS.secretAccessKeyField <*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
<*> areq (selectFieldList mediatypes) "Media Type" (Just MediaOmitted) <*> areq (selectFieldList mediatypes) "Media Type" (Just MediaOmitted)
<*> areq (textField `withExpandableNote` ("Help", itemNameHelp)) "Item Name" Nothing <*> areq (textField `withExpandableNote` ("Help", itemNameHelp)) "Item Name" Nothing
where where
@ -95,13 +99,19 @@ itemNameHelp = [whamlet|
will be uploaded to your Internet Archive item. will be uploaded to your Internet Archive item.
|] |]
iaCredsAForm :: AForm WebApp WebApp AWS.AWSCreds iaCredsAForm :: Maybe CredPair -> AForm WebApp WebApp AWS.AWSCreds
iaCredsAForm = AWS.AWSCreds iaCredsAForm defcreds = AWS.AWSCreds
<$> accessKeyIDFieldWithHelp <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> AWS.secretAccessKeyField <*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
accessKeyIDFieldWithHelp :: AForm WebApp WebApp Text #ifdef WITH_S3
accessKeyIDFieldWithHelp = AWS.accessKeyIDField help 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 where
help = [whamlet| help = [whamlet|
<a href="http://archive.org/account/s3.php"> <a href="http://archive.org/account/s3.php">
@ -114,8 +124,9 @@ getAddIAR = postAddIAR
postAddIAR :: Handler RepHtml postAddIAR :: Handler RepHtml
#ifdef WITH_S3 #ifdef WITH_S3
postAddIAR = iaConfigurator $ do postAddIAR = iaConfigurator $ do
defcreds <- liftAnnex previouslyUsedIACreds
((result, form), enctype) <- lift $ ((result, form), enctype) <- lift $
runFormPost $ renderBootstrap iaInputAForm runFormPost $ renderBootstrap $ iaInputAForm defcreds
case result of case result of
FormSuccess input -> lift $ do FormSuccess input -> lift $ do
let name = escapeBucket $ T.unpack $ itemName input let name = escapeBucket $ T.unpack $ itemName input
@ -155,8 +166,9 @@ postEnableIAR _ = error "S3 not supported by this build"
#ifdef WITH_S3 #ifdef WITH_S3
enableIARemote :: UUID -> Widget enableIARemote :: UUID -> Widget
enableIARemote uuid = do enableIARemote uuid = do
defcreds <- liftAnnex previouslyUsedIACreds
((result, form), enctype) <- lift $ ((result, form), enctype) <- lift $
runFormPost $ renderBootstrap iaCredsAForm runFormPost $ renderBootstrap $ iaCredsAForm defcreds
case result of case result of
FormSuccess creds -> lift $ do FormSuccess creds -> lift $ do
m <- liftAnnex readRemoteLog m <- liftAnnex readRemoteLog

39
Assistant/WebApp/Configurators/WebDAV.hs
View file

@ -1,6 +1,6 @@
{- git-annex assistant webapp configurators for WebDAV remotes {- 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. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -24,6 +24,7 @@ import Logs.Remote
import qualified Data.Map as M import qualified Data.Map as M
#endif #endif
import qualified Data.Text as T import qualified Data.Text as T
import Network.URI
webDAVConfigurator :: Widget -> Handler RepHtml webDAVConfigurator :: Widget -> Handler RepHtml
webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration) webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration)
@ -42,18 +43,18 @@ data WebDAVInput = WebDAVInput
toCredPair :: WebDAVInput -> CredPair toCredPair :: WebDAVInput -> CredPair
toCredPair input = (T.unpack $ user input, T.unpack $ password input) toCredPair input = (T.unpack $ user input, T.unpack $ password input)
boxComAForm :: AForm WebApp WebApp WebDAVInput boxComAForm :: Maybe CredPair -> AForm WebApp WebApp WebDAVInput
boxComAForm = WebDAVInput boxComAForm defcreds = WebDAVInput
<$> areq textField "Username or Email" Nothing <$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
<*> areq passwordField "Box.com Password" Nothing <*> areq passwordField "Box.com Password" (T.pack . snd <$> defcreds)
<*> areq checkBoxField "Share this account with other devices and friends?" (Just True) <*> areq checkBoxField "Share this account with other devices and friends?" (Just True)
<*> areq textField "Directory" (Just "annex") <*> areq textField "Directory" (Just "annex")
<*> enableEncryptionField <*> enableEncryptionField
webDAVCredsAForm :: AForm WebApp WebApp WebDAVInput webDAVCredsAForm :: Maybe CredPair -> AForm WebApp WebApp WebDAVInput
webDAVCredsAForm = WebDAVInput webDAVCredsAForm defcreds = WebDAVInput
<$> areq textField "Username or Email" Nothing <$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
<*> areq passwordField "Password" Nothing <*> areq passwordField "Password" (T.pack . snd <$> defcreds)
<*> pure False <*> pure False
<*> pure T.empty <*> pure T.empty
<*> pure NoEncryption -- not used! <*> pure NoEncryption -- not used!
@ -63,8 +64,9 @@ getAddBoxComR = postAddBoxComR
postAddBoxComR :: Handler RepHtml postAddBoxComR :: Handler RepHtml
#ifdef WITH_WEBDAV #ifdef WITH_WEBDAV
postAddBoxComR = boxConfigurator $ do postAddBoxComR = boxConfigurator $ do
defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"
((result, form), enctype) <- lift $ ((result, form), enctype) <- lift $
runFormPost $ renderBootstrap boxComAForm runFormPost $ renderBootstrap $ boxComAForm defcreds
case result of case result of
FormSuccess input -> lift $ FormSuccess input -> lift $
makeWebDavRemote "box.com" (toCredPair input) setgroup $ M.fromList makeWebDavRemote "box.com" (toCredPair input) setgroup $ M.fromList
@ -106,8 +108,11 @@ postEnableWebDAVR uuid = do
webDAVConfigurator $ showform name url webDAVConfigurator $ showform name url
where where
showform name url = do showform name url = do
defcreds <- liftAnnex $
maybe (pure Nothing) previouslyUsedWebDAVCreds $
urlHost url
((result, form), enctype) <- lift $ ((result, form), enctype) <- lift $
runFormPost $ renderBootstrap webDAVCredsAForm runFormPost $ renderBootstrap $ webDAVCredsAForm defcreds
case result of case result of
FormSuccess input -> lift $ FormSuccess input -> lift $
makeWebDavRemote name (toCredPair input) (const noop) M.empty makeWebDavRemote name (toCredPair input) (const noop) M.empty
@ -131,3 +136,15 @@ makeWebDavRemote name creds setup config = do
liftAssistant $ syncRemote r liftAssistant $ syncRemote r
redirect $ EditNewCloudRepositoryR $ Remote.uuid r redirect $ EditNewCloudRepositoryR $ Remote.uuid r
#endif #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)

7
Remote/WebDAV.hs
View file

@ -7,7 +7,7 @@
{-# LANGUAGE ScopedTypeVariables, CPP #-} {-# LANGUAGE ScopedTypeVariables, CPP #-}
module Remote.WebDAV (remote, davCreds, setCredsEnv) where module Remote.WebDAV (remote, davCreds, setCredsEnv, configUrl) where
import Network.Protocol.HTTP.DAV import Network.Protocol.HTTP.DAV
import qualified Data.Map as M 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 :: Remote -> a -> ((DavUrl, DavUser, DavPass) -> Annex a) -> Annex a
davAction r unconfigured action = do davAction r unconfigured action = do
mcreds <- getCreds (config r) (uuid r) mcreds <- getCreds (config r) (uuid r)
case (mcreds, M.lookup "url" $ config r) of case (mcreds, configUrl r) of
(Just (user, pass), Just url) -> (Just (user, pass), Just url) ->
action (url, toDavUser user, toDavPass pass) action (url, toDavUser user, toDavPass pass)
_ -> return unconfigured _ -> return unconfigured
configUrl :: Remote -> Maybe DavUrl
configUrl r = M.lookup "url" $ config r
toDavUser :: String -> DavUser toDavUser :: String -> DavUser
toDavUser = B8.fromString toDavUser = B8.fromString

3
debian/changelog vendored
View file

@ -43,6 +43,9 @@ git-annex (4.20130418) UNRELEASED; urgency=low
* To enable an existing special remote, the new enableremote command * To enable an existing special remote, the new enableremote command
must be used. The initremote command now is used only to create must be used. The initremote command now is used only to create
new special remotes. 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 -- Joey Hess <joeyh@debian.org> Thu, 18 Apr 2013 16:22:48 -0400