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