Merge branch 'master' into xmpp

Conflicts:
	Assistant/Threads/MountWatcher.hs
	Assistant/Threads/NetWatcher.hs

17 files changed, 190 insertions, 15 deletions

diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index 0d3ebcfac..de7665dad 100644
--- a/Assistant/Ssh.hs
+++ b/Assistant/Ssh.hs
@@ -9,6 +9,7 @@ module Assistant.Ssh where
 
 import Common.Annex
 import Utility.TempFile
+import Utility.UserInfo
 
 import Data.Text (Text)
 import qualified Data.Text as T
diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs
index c36b544a7..881f9d8d6 100644
--- a/Assistant/Threads/MountWatcher.hs
+++ b/Assistant/Threads/MountWatcher.hs
@@ -52,7 +52,8 @@ mountWatcherThread st handle scanremotes pushnotifier = thread $
 #if WITH_DBUS
 
 dbusThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> IO ()
-dbusThread st dstatus scanremotes pushnotifier = E.catch (go =<< connectSession) onerr
+dbusThread st dstatus scanremotes pushnotifier =
+	E.catch (runClient getSessionAddress go) onerr
 	where
 		go client = ifM (checkMountMonitor client)
 			( do
@@ -74,7 +75,7 @@ dbusThread st dstatus scanremotes pushnotifier = E.catch (go =<< connectSession)
 		onerr :: E.SomeException -> IO ()
 		onerr e = do
 			runThreadState st $
-				warning $ "Failed to use dbus; falling back to mtab polling (" ++ show e ++ ")"
+				warning $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")"
 			pollinstead
 		pollinstead = pollingThread st dstatus scanremotes pushnotifier
 
diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs
index 2c637f414..5e6fcea06 100644
--- a/Assistant/Threads/NetWatcher.hs
+++ b/Assistant/Threads/NetWatcher.hs
@@ -58,7 +58,8 @@ netWatcherFallbackThread st dstatus scanremotes pushnotifier = thread $
 #if WITH_DBUS
 
 dbusThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> IO ()
-dbusThread st dstatus scanremotes pushnotifier = E.catch (go =<< connectSystem) onerr
+dbusThread st dstatus scanremotes pushnotifier =
+	E.catch (runClient getSystemAddress go) onerr
 	where
 		go client = ifM (checkNetMonitor client)
 			( do
@@ -70,7 +71,7 @@ dbusThread st dstatus scanremotes pushnotifier = E.catch (go =<< connectSystem)
 			)
 		onerr :: E.SomeException -> IO ()
 		onerr e = runThreadState st $
-			warning $ "Failed to use dbus; falling back to polling (" ++ show e ++ ")"
+			warning $ "dbus failed; falling back to polling (" ++ show e ++ ")"
 		handle = do
 			debug thisThread ["detected network connection"]
 			handleConnection st dstatus scanremotes pushnotifier
diff --git a/Git/Config.hs b/Git/Config.hs
index cc9b27b69..0d6d67fc0 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -15,6 +15,7 @@ import Common
 import Git
 import Git.Types
 import qualified Git.Construct
+import Utility.UserInfo
 
 {- Returns a single git config setting, or a default value if not set. -}
 get :: String -> String -> Repo -> String
diff --git a/Git/Construct.hs b/Git/Construct.hs
index 3d39b0801..663303c15 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -27,6 +27,7 @@ import Common
 import Git.Types
 import Git
 import qualified Git.Url as Url
+import Utility.UserInfo
 
 {- Finds the git repository used for the cwd, which may be in a parent
  - directory. -}
diff --git a/Init.hs b/Init.hs
index aae10160d..0b3605e41 100644
--- a/Init.hs
+++ b/Init.hs
@@ -20,20 +20,16 @@ import qualified Annex.Branch
 import Logs.UUID
 import Annex.Version
 import Annex.UUID
-
-import System.Posix.User
+import Utility.UserInfo
 
 genDescription :: Maybe String -> Annex String
 genDescription (Just d) = return d
 genDescription Nothing = do
 	hostname <- maybe "" id <$> liftIO getHostname
 	let at = if null hostname then "" else "@"
-	username <- clicketyclickety
+	username <- liftIO myUserName
 	reldir <- liftIO . relHome =<< fromRepo Git.repoPath
 	return $ concat [username, at, hostname, ":", reldir]
-	where
-		clicketyclickety = liftIO $ userName <$>
-			(getUserEntryForID =<< getEffectiveUserID)
 
 initialize :: Maybe String -> Annex ()
 initialize mdescription = do
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 916095cc9..375c5c352 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -26,6 +26,7 @@ import Remote.Helper.Encryptable
 import Crypto
 import Data.ByteString.Lazy.UTF8 (fromString)
 import Data.Digest.Pure.SHA
+import Utility.UserInfo
 
 type BupRepo = String
 
diff --git a/Utility/DBus.hs b/Utility/DBus.hs
index cfd06f762..3b34e00ac 100644
--- a/Utility/DBus.hs
+++ b/Utility/DBus.hs
@@ -12,6 +12,8 @@ module Utility.DBus where
 import DBus.Client
 import DBus
 import Data.Maybe
+import Control.Concurrent
+import Control.Exception as E
 
 type ServiceName = String
 
@@ -26,3 +28,58 @@ callDBus client name params = call_ client $
 		{ methodCallDestination = Just "org.freedesktop.DBus"
 		, methodCallBody = params
 		}
+
+{- Connects to the bus, and runs the client action.
+ - 
+ - Throws a ClientError, and closes the connection if it fails to
+ - process an incoming message, or if the connection is lost.
+ - Unlike DBus's usual interface, this error is thrown at the top level,
+ - rather than inside the clientThreadRunner, so it can be caught, and
+ - runClient re-run as needed. -}
+runClient :: IO (Maybe Address) -> (Client -> IO ()) -> IO ()
+runClient getaddr clientaction = do
+	env <- getaddr
+	case env of
+		Nothing -> throwIO (clientError "runClient: unable to determine DBUS address")
+		Just addr -> do
+			{- The clientaction will set up listeners, which
+			 - run in a different thread. We block while
+			 - they're running, until our threadrunner catches
+			 - a ClientError, which it will put into the MVar
+			 - to be rethrown here. -}
+			mv <- newEmptyMVar
+			let tr = threadrunner (putMVar mv)
+			let opts = defaultClientOptions { clientThreadRunner = tr }
+			client <- connectWith opts addr
+			clientaction client
+			e <- takeMVar mv
+			disconnect client
+			throw e
+	where
+		threadrunner storeerr io = loop
+			where
+				loop = catchClientError (io >> loop) storeerr
+
+{- Connects to the bus, and runs the client action.
+ -
+ - If the connection is lost, runs onretry, which can do something like
+ - a delay, or printing a warning, and has a state value (useful for
+ - exponential backoff). Once onretry returns, the connection is retried.
+ - 
+ - Warning: Currently connectWith can throw a SocketError and leave behind
+ - an open FD. So each retry leaks one FD. -}
+persistentClient :: IO (Maybe Address) -> v -> (SomeException -> v -> IO v) -> (Client -> IO ()) -> IO ()
+persistentClient getaddr v onretry clientaction = do
+	{- runClient can fail with not just ClientError, but also other
+	 - things, if dbus is not running. -}
+	r <- E.try (runClient getaddr clientaction) :: IO (Either SomeException ())
+	either retry return r
+	where
+		retry e = do
+			v' <- onretry e v
+			persistentClient getaddr v' onretry clientaction
+
+{- Catches only ClientError -}
+catchClientError :: IO () -> (ClientError -> IO ()) -> IO ()
+catchClientError io handler = do
+	either handler return =<< (E.try io :: IO (Either ClientError ()))
diff --git a/Utility/FreeDesktop.hs b/Utility/FreeDesktop.hs
index 0845f3329..7aba1f272 100644
--- a/Utility/FreeDesktop.hs
+++ b/Utility/FreeDesktop.hs
@@ -25,6 +25,7 @@ module Utility.FreeDesktop (
 
 import Utility.Exception
 import Utility.Path
+import Utility.UserInfo
 import Utility.Process
 import Utility.PartialPrelude
 
diff --git a/Utility/Path.hs b/Utility/Path.hs
index 209ff1b0f..f4c2843fc 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -14,9 +14,9 @@ import System.Directory
 import Data.List
 import Data.Maybe
 import Control.Applicative
-import System.Posix.User
 
 import Utility.Monad
+import Utility.UserInfo
 
 {- Returns the parent directory of a path. Parent of / is "" -}
 parentDir :: FilePath -> FilePath
@@ -128,10 +128,6 @@ preserveOrder (l:ls) new = found ++ preserveOrder ls rest
 runPreserveOrder :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
 runPreserveOrder a files = preserveOrder files <$> a files
 
-{- Current user's home directory. -}
-myHomeDir :: IO FilePath
-myHomeDir = homeDirectory <$> (getUserEntryForID =<< getEffectiveUserID)
-
 {- Converts paths in the home directory to use ~/ -}
 relHome :: FilePath -> IO String
 relHome path = do
diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs
new file mode 100644
index 000000000..6e757548a
--- /dev/null
+++ b/Utility/UserInfo.hs
@@ -0,0 +1,32 @@
+{- user info
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.UserInfo (
+	myHomeDir,
+	myUserName
+) where
+
+import Control.Applicative
+import System.Posix.User
+import System.Posix.Env
+
+{- Current user's home directory.
+ -
+ - getpwent will fail on LDAP or NIS, so use HOME if set. -}
+myHomeDir :: IO FilePath
+myHomeDir = myVal ["HOME"] homeDirectory
+
+{- Current user's user name. -}
+myUserName :: IO String
+myUserName = myVal ["USER", "LOGNAME"] userName
+
+myVal :: [String] -> (UserEntry -> String) -> IO String
+myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars
+	where
+		check [] = return Nothing
+		check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v
+		getpwent = getUserEntryForID =<< getEffectiveUserID
diff --git a/debian/changelog b/debian/changelog
index 2278195c2..aa3eb9db5 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -24,6 +24,8 @@ git-annex (3.20121018) UNRELEASED; urgency=low
   * configure: Check that checksum programs produce correct checksums.
   * Re-enable dbus, using a new version of the library that fixes the memory
     leak.
+  * Use USER and HOME environment when set, and only fall back to getpwent,
+    which doesn't work with LDAP or NIS.
 
  -- Joey Hess <joeyh@debian.org>  Wed, 17 Oct 2012 14:24:10 -0400
 
diff --git a/doc/bugs/git-annex:_getUserEntryForID:_failed___40__Success__41__.mdwn b/doc/bugs/git-annex:_getUserEntryForID:_failed___40__Success__41__.mdwn
index a929048f6..976109c79 100644
--- a/doc/bugs/git-annex:_getUserEntryForID:_failed___40__Success__41__.mdwn
+++ b/doc/bugs/git-annex:_getUserEntryForID:_failed___40__Success__41__.mdwn
@@ -10,3 +10,4 @@ What version of git-annex are you using? On what operating system?
 Please provide any additional information below.
 
 
+> [[fixed|done]] --[[Joey]] 
diff --git a/doc/bugs/git-annex:_getUserEntryForID:_failed___40__Success__41__/comment_1_11a1615962325327466895d03e3d2379._comment b/doc/bugs/git-annex:_getUserEntryForID:_failed___40__Success__41__/comment_1_11a1615962325327466895d03e3d2379._comment
new file mode 100644
index 000000000..ef8800c21
--- /dev/null
+++ b/doc/bugs/git-annex:_getUserEntryForID:_failed___40__Success__41__/comment_1_11a1615962325327466895d03e3d2379._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="http://joeyh.name/"
+ ip="4.154.0.118"
+ subject="comment 1"
+ date="2012-10-25T18:52:52Z"
+ content="""
+This means it has been unable to look up your home directory in /etc/passwd. I wonder, are you using NIS or a similar thing that keeps your user entry out of /etc/passwd?
+"""]]
diff --git a/doc/bugs/git-annex:_getUserEntryForID:_failed___40__Success__41__/comment_2_eac51c3299e9fc04025675360969d537._comment b/doc/bugs/git-annex:_getUserEntryForID:_failed___40__Success__41__/comment_2_eac51c3299e9fc04025675360969d537._comment
new file mode 100644
index 000000000..dde7c0814
--- /dev/null
+++ b/doc/bugs/git-annex:_getUserEntryForID:_failed___40__Success__41__/comment_2_eac51c3299e9fc04025675360969d537._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="https://www.google.com/accounts/o8/id?id=AItOawniayrgSdVLUc3c6bf93VbO-_HT4hzxmyo"
+ nickname="Tobias"
+ subject="comment 2"
+ date="2012-10-25T21:29:05Z"
+ content="""
+Yes, the system is using LDAP as user backend... Any idea how I can use git-annex with LDAP as user backend?
+"""]]
diff --git a/doc/design/assistant/blog/day_114__xmpp.mdwn b/doc/design/assistant/blog/day_114__xmpp.mdwn
new file mode 100644
index 000000000..617824d48
--- /dev/null
+++ b/doc/design/assistant/blog/day_114__xmpp.mdwn
@@ -0,0 +1,56 @@
+Had to toss out my XMPP presence hack. Turns out that, at least in Google
+Talk, presence info is not sent to clients that have marked themselves
+unavailable, and that means the assistant would not see notifications, as it
+was nearly always marked unavailable as part of the hack.
+
+I tried writing a test program that uses XMPP personal eventing, only
+to find that Google Talk rejected my messages. I'm not 100% sure my
+messages were right, but I was directly copying the example in the RFC,
+and prosody accepted them. I could not seem to get a list of extensions out
+of Google Talk either, so I don't know if it doesn't support personal
+eventing, or perhaps only supports certian specific types of events.
+
+So, plan C... using XMPP [presence extended content](http://xmpp.org/rfcs/rfc6121.html#presence-extended).
+The assistant generates a presence message tagged "xa" (Extended Away),
+which hopefully will make it not seem present to clients.
+And to that presence message, I add my own XML element:
+
+	<git-annex xmlns='git-annex' push="uuid,uuid" />
+
+This is all entirely legal, and not at all a hack.
+(Aside from this not really being presence info.) Isn't XML fun?
+
+And plan C works, with Google Talk, and prosody. I've successfully gotten
+push notifications flowing over XMPP!
+
+----
+
+Spent some hours dealing with an unusual probolem: git-annex started
+segfaulting intermittently on startup with the new XMPP code. 
+
+Haskell code is not supposed to segfault..
+
+I think this was probably due to not using a bound thread for XMPP,
+so if haskell's runtime system recheduled its green thread onto a different
+OS thread during startup, when it's setting up TLS, it'd make gnuTLS very
+unhappy.
+
+So, fixed it to use a bound thread. Will wait and see if the crash is gone.
+
+----
+
+Re-enabled DBUS support, using a new version of the library that avoids the
+memory leak. Will need further changes to the library to support
+reconnecting to dbus.
+
+----
+
+Next will be a webapp configuration UI for XMPP. Various parts of the
+webapp will direct the user to set up XMPP, when appropriate, especially
+when the user sets up a cloud remote.
+
+To make XMPP sufficiently easy to configure, I need to check SRV records to
+find the XMPP server, which is an unexpected PITA because `getaddrinfo`
+can't do that. There are several haskell DNS libraries that I could use for
+SRV, or I could use the `host` command: 
+`host -t SRV _xmpp-client._tcp.gmail.com`
diff --git a/doc/forum/recover_deleted_files___63__/comment_3_376de81c70799bf409be189a48234815._comment b/doc/forum/recover_deleted_files___63__/comment_3_376de81c70799bf409be189a48234815._comment
new file mode 100644
index 000000000..89edb17eb
--- /dev/null
+++ b/doc/forum/recover_deleted_files___63__/comment_3_376de81c70799bf409be189a48234815._comment
@@ -0,0 +1,12 @@
+[[!comment format=mdwn
+ username="ka7"
+ ip="2001:7b8:155d:0:222:64ff:fe16:dc52"
+ subject="ok, that worked."
+ date="2012-10-25T20:15:26Z"
+ content="""
+i think of a kind of \"WORM-library\", so basically just add, not allow to remove content. (at least not for the user thru the mounted device)
+- so a script to add/commit -- but as stag-1 check for delete files and get them back. some git magic needed, but should be doable.
+- or thru \"samba\" parameters set to add but not delete/overwrite files.  (read yes, write yes, delete no) -- to be proved thats possible, but not your job :) ( annex-ing via cron every /5 or via inotify)
+so yea, will play for a while and maybe come back with new. thanks to everybody. 
+<3 git-annex <3
+"""]]