diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs index c16abeb006..b54ef43699 100644 --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -20,6 +20,7 @@ import Types.Remote (RemoteConfig) import Types.StandardGroups import Logs.PreferredContent import Logs.Remote +import Creds import Yesod import qualified Data.Text as T @@ -34,20 +35,26 @@ boxConfigurator = page "Add a Box.com repository" (Just Config) data WebDAVInput = WebDAVInput { user :: Text , password :: Text + , embedCreds :: Bool , directory :: Text } +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 + <*> areq checkBoxField "Share this account with friends?" (Just True) <*> areq textField "Directory" (Just "annex") webDAVCredsAForm :: AForm WebApp WebApp WebDAVInput webDAVCredsAForm = WebDAVInput <$> areq textField "Username or Email" Nothing <*> areq passwordField "Password" Nothing - <*> pure (T.empty) + <*> pure False + <*> pure T.empty getAddBoxComR :: Handler RepHtml #ifdef WITH_WEBDAV @@ -56,8 +63,9 @@ getAddBoxComR = boxConfigurator $ do runFormGet $ renderBootstrap boxComAForm case result of FormSuccess input -> lift $ - makeWebDavRemote "box.com" input setgroup $ M.fromList + makeWebDavRemote "box.com" (toCredPair input) setgroup $ M.fromList [ ("encryption", "shared") + , ("embedcreds", if embedCreds input then "yes" else "no") , ("type", "webdav") , ("url", "https://www.box.com/dav/" ++ T.unpack (directory input)) -- Box.com has a max file size of 100 mb, but @@ -80,18 +88,23 @@ getEnableWebDAVR uuid = do let c = fromJust $ M.lookup uuid m let name = fromJust $ M.lookup "name" c let url = fromJust $ M.lookup "url" c - go name url + mcreds <- runAnnex Nothing $ + getRemoteCredPairFor "webdav" c (WebDAV.davCreds uuid) + case mcreds of + Just creds -> webDAVConfigurator $ lift $ + makeWebDavRemote name creds (const noop) M.empty + Nothing + | "box.com/" `isInfixOf` url -> + boxConfigurator $ showform name url + | otherwise -> + webDAVConfigurator $ showform name url where - go name url - | "box.com/" `isInfixOf` url = boxConfigurator $ enable name url - | otherwise = webDAVConfigurator $ enable name url - - enable name url = do + showform name url = do ((result, form), enctype) <- lift $ runFormGet $ renderBootstrap webDAVCredsAForm case result of - FormSuccess creds -> lift $ - makeWebDavRemote name creds (const noop) M.empty + FormSuccess input -> lift $ + makeWebDavRemote name (toCredPair input) (const noop) M.empty _ -> do description <- lift $ runAnnex "" $ T.pack . concat <$> Remote.prettyListUUIDs [uuid] @@ -101,10 +114,10 @@ getEnableWebDAVR _ = error "WebDAV not supported by this build" #endif #ifdef WITH_WEBDAV -makeWebDavRemote :: String -> WebDAVInput -> (Remote -> Handler ()) -> RemoteConfig -> Handler () -makeWebDavRemote name input setup config = do +makeWebDavRemote :: String -> CredPair -> (Remote -> Handler ()) -> RemoteConfig -> Handler () +makeWebDavRemote name creds setup config = do remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0 - liftIO $ WebDAV.setCredsEnv (T.unpack $ user input, T.unpack $ password input) + liftIO $ WebDAV.setCredsEnv creds r <- liftAssistant $ liftAnnex $ addRemote $ do makeSpecialRemote name WebDAV.remote config return remotename diff --git a/Creds.hs b/Creds.hs index f5ea550000..06d3a52f90 100644 --- a/Creds.hs +++ b/Creds.hs @@ -34,7 +34,7 @@ data CredPairStorage = CredPairStorage {- Stores creds in a remote's configuration, if the remote allows - that. Otherwise, caches them locally. -} setRemoteCredPair :: RemoteConfig -> CredPairStorage -> Annex RemoteConfig -setRemoteCredPair c storage = go =<< getRemoteCredPair' c storage +setRemoteCredPair c storage = go =<< getRemoteCredPair c storage where go (Just creds) | embedCreds c = case credPairRemoteKey storage of @@ -58,8 +58,8 @@ setRemoteCredPair c storage = go =<< getRemoteCredPair' c storage {- Gets a remote's credpair, from the environment if set, otherwise - from the cache in gitAnnexCredsDir, or failing that, from the - value in RemoteConfig. -} -getRemoteCredPair :: String -> RemoteConfig -> CredPairStorage -> Annex (Maybe CredPair) -getRemoteCredPair this c storage = maybe missing (return . Just) =<< getRemoteCredPair' c storage +getRemoteCredPairFor :: String -> RemoteConfig -> CredPairStorage -> Annex (Maybe CredPair) +getRemoteCredPairFor this c storage = maybe missing (return . Just) =<< getRemoteCredPair c storage where (loginvar, passwordvar) = credPairEnvironment storage missing = do @@ -70,8 +70,8 @@ getRemoteCredPair this c storage = maybe missing (return . Just) =<< getRemoteCr ] return Nothing -getRemoteCredPair' :: RemoteConfig -> CredPairStorage -> Annex (Maybe CredPair) -getRemoteCredPair' c storage = maybe fromcache (return . Just) =<< fromenv +getRemoteCredPair :: RemoteConfig -> CredPairStorage -> Annex (Maybe CredPair) +getRemoteCredPair c storage = maybe fromcache (return . Just) =<< fromenv where fromenv = liftIO $ getEnvCredPair storage fromcache = maybe fromconfig (return . Just) =<< readCacheCredPair storage @@ -103,8 +103,6 @@ getEnvCredPair storage = liftM2 (,) (uenv, penv) = credPairEnvironment storage get = catchMaybeIO . getEnv - - {- Stores a CredPair in the environment. -} setEnvCredPair :: CredPair -> CredPairStorage -> IO () setEnvCredPair (l, p) storage = do diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index f960c517fa..55b704a333 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -221,7 +221,7 @@ glacierParams c params = datacenter:params (fromJust $ M.lookup "datacenter" c) glacierEnv :: RemoteConfig -> UUID -> Annex (Maybe [(String, String)]) -glacierEnv c u = go =<< getRemoteCredPair "glacier" c creds +glacierEnv c u = go =<< getRemoteCredPairFor "glacier" c creds where go Nothing = return Nothing go (Just (user, pass)) = do diff --git a/Remote/S3.hs b/Remote/S3.hs index 400f3e0279..ba5fb949bd 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -262,7 +262,7 @@ s3ConnectionRequired c u = maybe (error "Cannot connect to S3") return =<< s3Connection c u s3Connection :: RemoteConfig -> UUID -> Annex (Maybe AWSConnection) -s3Connection c u = go =<< getRemoteCredPair "S3" c (AWS.creds u) +s3Connection c u = go =<< getRemoteCredPairFor "S3" c (AWS.creds u) where go Nothing = return Nothing go (Just (ak, sk)) = return $ Just $ AWSConnection host port ak sk diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index b303dbe594..a5bba716bc 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -7,7 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Remote.WebDAV (remote, setCredsEnv) where +module Remote.WebDAV (remote, davCreds, setCredsEnv) where import Network.Protocol.HTTP.DAV import qualified Data.Map as M @@ -321,7 +321,7 @@ noProps :: XML.Document noProps = XML.parseText_ XML.def $ LT.pack "\n" getCreds :: RemoteConfig -> UUID -> Annex (Maybe CredPair) -getCreds c u = getRemoteCredPair "webdav" c (davCreds u) +getCreds c u = getRemoteCredPairFor "webdav" c (davCreds u) davCreds :: UUID -> CredPairStorage davCreds u = CredPairStorage diff --git a/debian/changelog b/debian/changelog index aebe385a67..37c322acdf 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +git-annex (3.20121128) UNRELEASED; urgency=low + + * webapp: Defaults to sharing box.com account info with friends, allowing + one-click enabling of the repository. + + -- Joey Hess Wed, 28 Nov 2012 13:31:07 -0400 + git-annex (3.20121127) unstable; urgency=low * Fix dirContentsRecursive, which had missed some files in deeply nested