Merge branch 'master' into xmpp

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

4 files changed, 91 insertions, 5 deletions

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