{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE OverloadedStrings #-}

-- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

-- | D-Bus clients are an abstraction over the lower-level messaging
-- system. When combined with an external daemon called the \"bus\", clients
-- can perform remote procedure calls to other clients on the bus.
--
-- Clients may also listen for or emit /signals/, which are asynchronous
-- broadcast notifications.
--
-- Example: connect to the session bus, and get a list of active names.
--
-- @
--{-\# LANGUAGE OverloadedStrings \#-}
--
--import Data.List (sort)
--import DBus
--import DBus.Client
--
--main = do
--    client <- 'connectSession'
--    //
--    \-- Request a list of connected clients from the bus
--    reply <- 'call_' client ('methodCall' \"\/org\/freedesktop\/DBus\" \"org.freedesktop.DBus\" \"ListNames\")
--        { 'methodCallDestination' = Just \"org.freedesktop.DBus\"
--        }
--    //
--    \-- org.freedesktop.DBus.ListNames() returns a single value, which is
--    \-- a list of names (here represented as [String])
--    let Just names = 'fromVariant' ('methodReturnBody' reply !! 0)
--    //
--    \-- Print each name on a line, sorted so reserved names are below
--    \-- temporary names.
--    mapM_ putStrLn (sort names)
-- @
--
module DBus.Client
    (
    -- * Clients
      Client

    -- * Connecting to a bus
    , connect
    , connectSystem
    , connectSession
    , connectStarter
    , disconnect

    -- * Sending method calls
    , call
    , call_
    , callNoReply

    -- * Receiving method calls
    , export
    , unexport
    , Method
    , method
    , Reply
    , replyReturn
    , replyError
    , throwError

    -- ** Automatic method signatures
    , AutoMethod
    , autoMethod

    -- * Signals
    , SignalHandler
    , addMatch
    , removeMatch
    , emit
    , listen

    -- ** Match rules
    , MatchRule
    , formatMatchRule
    , matchAny
    , matchSender
    , matchDestination
    , matchPath
    , matchInterface
    , matchMember

    -- * Name reservation
    , requestName
    , releaseName

    , RequestNameFlag
    , nameAllowReplacement
    , nameReplaceExisting
    , nameDoNotQueue

    , RequestNameReply(NamePrimaryOwner, NameInQueue, NameExists, NameAlreadyOwner)
    , ReleaseNameReply(NameReleased, NameNonExistent, NameNotOwner)

    -- * Client errors
    , ClientError
    , clientError
    , clientErrorMessage
    , clientErrorFatal

    -- * Advanced connection options
    , ClientOptions
    , clientSocketOptions
    , clientThreadRunner
    , defaultClientOptions
    , connectWith
    ) where

import           Control.Concurrent
import           Control.Exception (SomeException, throwIO)
import qualified Control.Exception
import           Control.Monad (forever, forM_, when)
import           Data.Bits ((.|.))
import           Data.IORef
import           Data.List (foldl', intercalate)
import qualified Data.Map
import           Data.Map (Map)
import           Data.Maybe (catMaybes, listToMaybe)
import           Data.Typeable (Typeable)
import           Data.Unique
import           Data.Word (Word32)

import           DBus
import qualified DBus.Introspection as I
import qualified DBus.Socket
import           DBus.Transport (TransportOpen, SocketTransport)

data ClientError = ClientError
    { clientErrorMessage :: String
    , clientErrorFatal :: Bool
    }
    deriving (Eq, Show, Typeable)

instance Control.Exception.Exception ClientError

clientError :: String -> ClientError
clientError msg = ClientError msg True

-- | An active client session to a message bus. Clients may send or receive
-- method calls, and listen for or emit signals.
data Client = Client
    { clientSocket :: DBus.Socket.Socket
    , clientPendingCalls :: IORef (Map Serial (MVar (Either MethodError MethodReturn)))
    , clientSignalHandlers :: IORef (Map Unique SignalHandler)
    , clientObjects :: IORef (Map ObjectPath ObjectInfo)
    , clientThreadID :: ThreadId
    }

data ClientOptions t = ClientOptions
    {
    -- | Options for the underlying socket, for advanced use cases. See
    -- the "DBus.Socket" module.
      clientSocketOptions :: DBus.Socket.SocketOptions t

    -- | A function to run the client thread. The provided IO computation
    -- should be called repeatedly; each time it is called, it will process
    -- one incoming message.
    --
    -- The provided computation will throw a 'ClientError' if it fails to
    -- process an incoming message, or if the connection is lost.
    --
    -- The default implementation is 'forever'.
    , clientThreadRunner :: IO () -> IO ()
    }

type Callback = (ReceivedMessage -> IO ())

type FormattedMatchRule = String
data SignalHandler = SignalHandler Unique FormattedMatchRule (IORef Bool) (Signal -> IO ())

data Reply
    = ReplyReturn [Variant]
    | ReplyError ErrorName [Variant]

-- | Reply to a method call with a successful return, containing the given body.
replyReturn :: [Variant] -> Reply
replyReturn = ReplyReturn

-- | Reply to a method call with an error, containing the given error name and
-- body.
--
-- Typically, the first item of the error body is a string with a message
-- describing the error.
replyError :: ErrorName -> [Variant] -> Reply
replyError = ReplyError

data Method = Method InterfaceName MemberName Signature Signature (MethodCall -> IO Reply)

type ObjectInfo = Map InterfaceName InterfaceInfo
type InterfaceInfo = Map MemberName MethodInfo
data MethodInfo = MethodInfo Signature Signature Callback

-- | Connect to the bus specified in the environment variable
-- @DBUS_SYSTEM_BUS_ADDRESS@, or to
-- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@
-- is not set.
--
-- Throws a 'ClientError' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid
-- address, or if connecting to the bus failed.
connectSystem :: IO Client
connectSystem = do
    env <- getSystemAddress
    case env of
        Nothing -> throwIO (clientError "connectSystem: DBUS_SYSTEM_BUS_ADDRESS is invalid.")
        Just addr -> connect addr

-- | Connect to the bus specified in the environment variable
-- @DBUS_SESSION_BUS_ADDRESS@, which must be set.
--
-- Throws a 'ClientError' if @DBUS_SESSION_BUS_ADDRESS@ is unset, contains an
-- invalid address, or if connecting to the bus failed.
connectSession :: IO Client
connectSession = do
    env <- getSessionAddress
    case env of
        Nothing -> throwIO (clientError "connectSession: DBUS_SESSION_BUS_ADDRESS is missing or invalid.")
        Just addr -> connect addr

-- | Connect to the bus specified in the environment variable
-- @DBUS_STARTER_ADDRESS@, which must be set.
--
-- Throws a 'ClientError' if @DBUS_STARTER_ADDRESS@ is unset, contains an
-- invalid address, or if connecting to the bus failed.
connectStarter :: IO Client
connectStarter = do
    env <- getStarterAddress
    case env of
        Nothing -> throwIO (clientError "connectStarter: DBUS_STARTER_ADDRESS is missing or invalid.")
        Just addr -> connect addr

-- | Connect to the bus at the specified address.
--
-- Throws a 'ClientError' on failure.
connect :: Address -> IO Client
connect = connectWith defaultClientOptions

-- | Connect to the bus at the specified address, with the given connection
-- options. Most users should use 'connect' instead.
--
-- Throws a 'ClientError' on failure.
connectWith :: TransportOpen t => ClientOptions t -> Address -> IO Client
connectWith opts addr = do
    sock <- DBus.Socket.openWith (clientSocketOptions opts) addr

    pendingCalls <- newIORef Data.Map.empty
    signalHandlers <- newIORef Data.Map.empty
    objects <- newIORef Data.Map.empty

    let threadRunner = clientThreadRunner opts

    clientMVar <- newEmptyMVar
    threadID <- forkIO $ do
        client <- readMVar clientMVar
        threadRunner (mainLoop client)

    let client = Client
            { clientSocket = sock
            , clientPendingCalls = pendingCalls
            , clientSignalHandlers = signalHandlers
            , clientObjects = objects
            , clientThreadID = threadID
            }
    putMVar clientMVar client

    export client "/" [introspectRoot client]

    callNoReply client (methodCall dbusPath dbusInterface "Hello")
        { methodCallDestination = Just dbusName
        }

    return client

-- | Default client options. Uses the built-in Socket-based transport, which
-- supports the @tcp:@ and @unix:@ methods.
defaultClientOptions :: ClientOptions SocketTransport
defaultClientOptions = ClientOptions
    { clientSocketOptions = DBus.Socket.defaultSocketOptions
    , clientThreadRunner = forever
    }

-- | Stop a 'Client''s callback thread and close its underlying socket.
disconnect :: Client -> IO ()
disconnect client = do
    killThread (clientThreadID client)
    disconnect' client

disconnect' :: Client -> IO ()
disconnect' client = do
    pendingCalls <- atomicModifyIORef (clientPendingCalls client) (\p -> (Data.Map.empty, p))
    forM_ (Data.Map.toList pendingCalls) $ \(k, v) -> do
        putMVar v (Left (methodError k errorDisconnected))

    atomicWriteIORef (clientSignalHandlers client) Data.Map.empty
    atomicWriteIORef (clientObjects client) Data.Map.empty

    DBus.Socket.close (clientSocket client)

mainLoop :: Client -> IO ()
mainLoop client = do
    let sock = clientSocket client

    received <- Control.Exception.try (DBus.Socket.receive sock)
    msg <- case received of
        Left err -> do
            disconnect' client
            throwIO (clientError (DBus.Socket.socketErrorMessage err))
        Right msg -> return msg

    dispatch client msg

dispatch :: Client -> ReceivedMessage -> IO ()
dispatch client = go where
    go (ReceivedMethodReturn _ msg) = dispatchReply (methodReturnSerial msg) (Right msg)
    go (ReceivedMethodError _ msg) = dispatchReply (methodErrorSerial msg) (Left msg)
    go (ReceivedSignal _ msg) = do
        handlers <- readIORef (clientSignalHandlers client)
        forM_ (Data.Map.toAscList handlers) (\(_, SignalHandler _ _ _ h) -> forkIO (h msg) >> return ())
    go received@(ReceivedMethodCall serial msg) = do
        objects <- readIORef (clientObjects client)
        let sender = methodCallSender msg
        _ <- forkIO $ case findMethod objects msg of
            Right io -> io received
            Left errName -> send_ client
                (methodError serial errName)
                    { methodErrorDestination = sender
                    }
                (\_ -> return ())
        return ()
    go _ = return ()

    dispatchReply serial result = do
        pending <- atomicModifyIORef
            (clientPendingCalls client)
            (\p -> case Data.Map.lookup serial p of
                Nothing -> (p, Nothing)
                Just mvar -> (Data.Map.delete serial p, Just mvar))
        case pending of
            Just mvar -> putMVar mvar result
            Nothing -> return ()

data RequestNameFlag
    = AllowReplacement
    | ReplaceExisting
    | DoNotQueue
    deriving (Eq, Show)

-- | Allow this client's reservation to be replaced, if another client
-- requests it with the 'nameReplaceExisting' flag.
--
-- If this client's reservation is replaced, this client will be added to the
-- wait queue unless the request also included the 'nameDoNotQueue' flag.
nameAllowReplacement :: RequestNameFlag
nameAllowReplacement = AllowReplacement

-- | If the name being requested is already reserved, attempt to replace it.
-- This only works if the current owner provided the 'nameAllowReplacement'
-- flag.
nameReplaceExisting :: RequestNameFlag
nameReplaceExisting = ReplaceExisting

-- | If the name is already in use, do not add this client to the queue, just
-- return an error.
nameDoNotQueue :: RequestNameFlag
nameDoNotQueue = DoNotQueue

data RequestNameReply
    -- | This client is now the primary owner of the requested name.
    = NamePrimaryOwner

    -- | The name was already reserved by another client, and replacement
    -- was either not attempted or not successful.
    | NameInQueue

    -- | The name was already reserved by another client, 'DoNotQueue'
    -- was set, and replacement was either not attempted or not
    -- successful.
    | NameExists

    -- | This client is already the primary owner of the requested name.
    | NameAlreadyOwner

    -- | Not exported; exists to generate a compiler warning if users
    -- case on the reply and forget to include a default case.
    | UnknownRequestNameReply Word32
    deriving (Eq, Show)

data ReleaseNameReply
    -- | This client has released the provided name.
    = NameReleased

    -- | The provided name is not assigned to any client on the bus.
    | NameNonExistent

    -- | The provided name is not assigned to this client.
    | NameNotOwner

    -- | Not exported; exists to generate a compiler warning if users
    -- case on the reply and forget to include a default case.
    | UnknownReleaseNameReply Word32
    deriving (Eq, Show)

encodeFlags :: [RequestNameFlag] -> Word32
encodeFlags = foldr (.|.) 0 . map flagValue where
    flagValue AllowReplacement = 0x1
    flagValue ReplaceExisting  = 0x2
    flagValue DoNotQueue       = 0x4

-- | Asks the message bus to assign the given name to this client. The bus
-- maintains a queue of possible owners, where the head of the queue is the
-- current (\"primary\") owner.
--
-- There are several uses for name reservation:
--
-- * Clients which export methods reserve a name so users and applications
--   can send them messages. For example, the GNOME Keyring reserves the name
--   @\"org.gnome.keyring\"@ on the user's session bus, and NetworkManager
--   reserves @\"org.freedesktop.NetworkManager\"@ on the system bus.
--
-- * When there are multiple implementations of a particular service, the
--   service standard will ususally include a generic bus name for the
--   service. This allows other clients to avoid depending on any particular
--   implementation's name. For example, both the GNOME Keyring and KDE
--   KWallet services request the @\"org.freedesktop.secrets\"@ name on the
--   user's session bus.
--
-- * A process with \"single instance\" behavior can use name assignment to
--   check whether the instance is already running, and invoke some method
--   on it (e.g. opening a new window).
--
-- Throws a 'ClientError' if the call failed.
requestName :: Client -> BusName -> [RequestNameFlag] -> IO RequestNameReply
requestName client name flags = do
    reply <- call_ client (methodCall dbusPath dbusInterface "RequestName")
        { methodCallDestination = Just dbusName
        , methodCallBody = [toVariant name, toVariant (encodeFlags flags)]
        }
    var <- case listToMaybe (methodReturnBody reply) of
        Just x -> return x
        Nothing -> throwIO (clientError "requestName: received empty response")
            { clientErrorFatal = False
            }
    code <- case fromVariant var of
        Just x -> return x
        Nothing -> throwIO (clientError ("requestName: received invalid response code " ++ showsPrec 11 var ""))
            { clientErrorFatal = False
            }
    return $ case code :: Word32 of
        1 -> NamePrimaryOwner
        2 -> NameInQueue
        3 -> NameExists
        4 -> NameAlreadyOwner
        _ -> UnknownRequestNameReply code

-- | Release a name that this client previously requested. See 'requestName'
-- for an explanation of name reservation.
--
-- Throws a 'ClientError' if the call failed.
releaseName :: Client -> BusName -> IO ReleaseNameReply
releaseName client name = do
    reply <- call_ client (methodCall dbusPath dbusInterface "ReleaseName")
        { methodCallDestination = Just dbusName
        , methodCallBody = [toVariant name]
        }
    var <- case listToMaybe (methodReturnBody reply) of
        Just x -> return x
        Nothing -> throwIO (clientError "releaseName: received empty response")
            { clientErrorFatal = False
            }
    code <- case fromVariant var of
        Just x -> return x
        Nothing -> throwIO (clientError ("releaseName: received invalid response code " ++ showsPrec 11 var ""))
            { clientErrorFatal = False
            }
    return $ case code :: Word32 of
        1 -> NameReleased
        2 -> NameNonExistent
        3 -> NameNotOwner
        _ -> UnknownReleaseNameReply code

send_ :: Message msg => Client -> msg -> (Serial -> IO a) -> IO a
send_ client msg io = do
    result <- Control.Exception.try (DBus.Socket.send (clientSocket client) msg io)
    case result of
        Right x -> return x
        Left err -> throwIO (clientError (DBus.Socket.socketErrorMessage err))
            { clientErrorFatal = DBus.Socket.socketErrorFatal err
            }

-- | Send a method call to the bus, and wait for the response.
--
-- Throws a 'ClientError' if the method call couldn't be sent, or if the reply
-- couldn't be parsed.
call :: Client -> MethodCall -> IO (Either MethodError MethodReturn)
call client msg = do
    -- If ReplyExpected is False, this function would block indefinitely
    -- if the remote side honors it.
    let safeMsg = msg
            { methodCallReplyExpected = True
            }
    mvar <- newEmptyMVar
    let ref = clientPendingCalls client
    serial <- send_ client safeMsg (\serial -> atomicModifyIORef ref (\p -> (Data.Map.insert serial mvar p, serial)))

    -- At this point, we wait for the reply to arrive. The user may cancel
    -- a pending call by sending this thread an exception via something
    -- like 'timeout'; in that case, we want to clean up the pending call.
    Control.Exception.onException
        (takeMVar mvar)
        (atomicModifyIORef_ ref (Data.Map.delete serial))

-- | Send a method call to the bus, and wait for the response.
--
-- Unsets the 'noReplyExpected' message flag before sending.
--
-- Throws a 'ClientError' if the method call couldn't sent, if the reply
-- couldn't be parsed, or if the reply was a 'MethodError'.
call_ :: Client -> MethodCall -> IO MethodReturn
call_ client msg = do
    result <- call client msg
    case result of
        Left err -> throwIO (clientError ("Call failed: " ++ methodErrorMessage err))
            { clientErrorFatal = methodErrorName err == errorDisconnected
            }
        Right ret -> return ret

-- | Send a method call to the bus, and do not wait for a response.
--
-- Sets the 'noReplyExpected' message flag before sending.
--
-- Throws a 'ClientError' if the method call couldn't be sent.
callNoReply :: Client -> MethodCall -> IO ()
callNoReply client msg = do
    -- Ensure that noReplyExpected is always set.
    let safeMsg = msg
            { methodCallReplyExpected = False
            }
    send_ client safeMsg (\_ -> return ())

-- | Request that the bus forward signals matching the given rule to this
-- client, and process them in a callback.
--
-- A received signal might be processed by more than one callback at a time.
-- Callbacks each run in their own thread.
--
-- The returned 'SignalHandler' can be passed to 'removeMatch'
-- to stop handling this signal.
--
-- Throws a 'ClientError' if the match rule couldn't be added to the bus.
addMatch :: Client -> MatchRule -> (Signal -> IO ()) -> IO SignalHandler
addMatch client rule io = do
    let formatted = case formatMatchRule rule of
            "" -> "type='signal'"
            x -> "type='signal'," ++ x

    handlerId <- newUnique
    registered <- newIORef True
    let handler = SignalHandler handlerId formatted registered (\msg -> when (checkMatchRule rule msg) (io msg))

    atomicModifyIORef (clientSignalHandlers client) (\hs -> (Data.Map.insert handlerId handler hs, ()))
    _ <- call_ client (methodCall dbusPath dbusInterface "AddMatch")
        { methodCallDestination = Just dbusName
        , methodCallBody = [toVariant formatted]
        }
    return handler

-- | Request that the bus stop forwarding signals for the given handler.
--
-- Throws a 'ClientError' if the match rule couldn't be removed from the bus.
removeMatch :: Client -> SignalHandler -> IO ()
removeMatch client (SignalHandler handlerId formatted registered _) = do
    shouldUnregister <- atomicModifyIORef registered (\wasRegistered -> (False, wasRegistered))
    when shouldUnregister $ do
        atomicModifyIORef (clientSignalHandlers client) (\hs -> (Data.Map.delete handlerId hs, ()))
        _ <- call_ client (methodCall dbusPath dbusInterface "RemoveMatch")
            { methodCallDestination = Just dbusName
            , methodCallBody = [toVariant formatted]
            }
        return ()

-- | Equivalent to 'addMatch', but does not return the added 'SignalHandler'.
listen :: Client -> MatchRule -> (Signal -> IO ()) -> IO ()
listen client rule io = addMatch client rule io >> return ()
{-# DEPRECATED listen "Prefer DBus.Client.addMatch in new code." #-}

-- | Emit the signal on the bus.
--
-- Throws a 'ClientError' if the signal message couldn't be sent.
emit :: Client -> Signal -> IO ()
emit client msg = send_ client msg (\_ -> return ())

-- | A match rule describes which signals a particular callback is interested
-- in. Use 'matchAny' to construct match rules.
--
-- Example: a match rule which matches signals sent by the root object.
--
-- @
--matchFromRoot :: MatchRule
--matchFromRoot = 'matchAny' { 'matchPath' = Just \"/\" }
-- @
data MatchRule = MatchRule
    {
    -- | If set, only receives signals sent from the given bus name.
    --
    -- The standard D-Bus implementation from <http://dbus.freedesktop.org/>
    -- almost always sets signal senders to the unique name of the sending
    -- client. If 'matchSender' is a requested name like
    -- @\"com.example.Foo\"@, it will not match any signals.
    --
    -- The exception is for signals sent by the bus itself, which always
    -- have a sender of @\"org.freedesktop.DBus\"@.
      matchSender :: Maybe BusName

    -- | If set, only receives signals sent to the given bus name.
    , matchDestination :: Maybe BusName

    -- | If set, only receives signals sent with the given path.
    , matchPath  :: Maybe ObjectPath

    -- | If set, only receives signals sent with the given interface name.
    , matchInterface :: Maybe InterfaceName

    -- | If set, only receives signals sent with the given member name.
    , matchMember :: Maybe MemberName
    }

instance Show MatchRule where
    showsPrec d rule = showParen (d > 10) (showString "MatchRule " . shows (formatMatchRule rule))

-- | Convert a match rule into the textual format accepted by the bus.
formatMatchRule :: MatchRule -> String
formatMatchRule rule = intercalate "," predicates where
    predicates = catMaybes
        [ f "sender" matchSender formatBusName
        , f "destination" matchDestination formatBusName
        , f "path" matchPath formatObjectPath
        , f "interface" matchInterface formatInterfaceName
        , f "member" matchMember formatMemberName
        ]

    f :: String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
    f key get text = do
        val <- fmap text (get rule)
        return (concat [key, "='", val, "'"])

-- | Match any signal.
matchAny :: MatchRule
matchAny = MatchRule Nothing Nothing Nothing Nothing Nothing

checkMatchRule :: MatchRule -> Signal -> Bool
checkMatchRule rule msg = and
    [ maybe True (\x -> signalSender msg == Just x) (matchSender rule)
    , maybe True (\x -> signalDestination msg == Just x) (matchDestination rule)
    , maybe True (== signalPath msg) (matchPath rule)
    , maybe True (== signalInterface msg) (matchInterface rule)
    , maybe True (== signalMember msg) (matchMember rule)
    ]

data MethodExc = MethodExc ErrorName [Variant]
    deriving (Show, Eq, Typeable)

instance Control.Exception.Exception MethodExc

-- | Normally, any exceptions raised while executing a method will be
-- given the generic @\"org.freedesktop.DBus.Error.Failed\"@ name.
-- 'throwError' allows the programmer to specify an error name, and provide
-- additional information to the remote application. You may use this instead
-- of 'Control.Exception.throwIO' to abort a method call.
throwError :: ErrorName
           -> String -- ^ Error message
           -> [Variant] -- ^ Additional items of the error body
           -> IO a
throwError name message extra = Control.Exception.throwIO (MethodExc name (toVariant message : extra))

-- | Define a method handler, which will accept method calls with the given
-- interface and member name.
--
-- Note that the input and output parameter signatures are used for
-- introspection, but are not checked when executing a method.
--
-- See 'autoMethod' for an easier way to export functions with simple
-- parameter and return types.
method :: InterfaceName
       -> MemberName
       -> Signature -- ^ Input parameter signature
       -> Signature -- ^ Output parameter signature
       -> (MethodCall -> IO Reply)
       -> Method
method iface name inSig outSig io = Method iface name inSig outSig
    (\msg -> Control.Exception.catch
        (Control.Exception.catch
            (io msg)
            (\(MethodExc name' vs') -> return (ReplyError name' vs')))
        (\exc -> return (ReplyError errorFailed
            [toVariant (show (exc :: SomeException))])))

-- | Export the given functions under the given 'ObjectPath' and
-- 'InterfaceName'.
--
-- Use 'autoMethod' to construct a 'Method' from a function that accepts and
-- returns simple types.
--
-- Use 'method' to construct a 'Method' from a function that handles parameter
-- conversion manually.
--
-- @
--ping :: MethodCall -> IO 'Reply'
--ping _ = replyReturn []
--
--sayHello :: String -> IO String
--sayHello name = return (\"Hello \" ++ name ++ \"!\")
--
--export client \"/hello_world\"
--    [ 'method' \"com.example.HelloWorld\" \"Ping\" ping
--    , 'autoMethod' \"com.example.HelloWorld\" \"Hello\" sayHello
--    ]
-- @
export :: Client -> ObjectPath -> [Method] -> IO ()
export client path methods = atomicModifyIORef (clientObjects client) addObject where
    addObject objs = (Data.Map.insert path info objs, ())

    info = foldl' addMethod Data.Map.empty (defaultIntrospect : methods)
    addMethod m (Method iface name inSig outSig cb) = Data.Map.insertWith'
        Data.Map.union iface
        (Data.Map.fromList [(name, MethodInfo inSig outSig (wrapCB cb))]) m

    wrapCB cb (ReceivedMethodCall serial msg) = do
        reply <- cb msg
        let sender = methodCallSender msg
        case reply of
            ReplyReturn vs -> send_ client (methodReturn serial)
                { methodReturnDestination = sender
                , methodReturnBody = vs
                } (\_ -> return ())
            ReplyError name vs -> send_ client (methodError serial name)
                { methodErrorDestination = sender
                , methodErrorBody = vs
                } (\_ -> return ())
    wrapCB _ _ = return ()

    defaultIntrospect = methodIntrospect $ do
        objects <- readIORef (clientObjects client)
        let Just obj = Data.Map.lookup path objects
        return (introspect path obj)

-- | Revokes the export of the given 'ObjectPath'. This will remove all
-- interfaces and methods associated with the path.
unexport :: Client -> ObjectPath -> IO ()
unexport client path = atomicModifyIORef (clientObjects client) deleteObject where
    deleteObject objs = (Data.Map.delete path objs, ())

findMethod :: Map ObjectPath ObjectInfo -> MethodCall -> Either ErrorName Callback
findMethod objects msg = case Data.Map.lookup (methodCallPath msg) objects of
    Nothing -> Left errorUnknownObject
    Just obj -> case methodCallInterface msg of
        Nothing -> let
            members = do
                iface <- Data.Map.elems obj
                case Data.Map.lookup (methodCallMember msg) iface of
                    Just member -> [member]
                    Nothing -> []
            in case members of
                [MethodInfo _ _ io] -> Right io
                _ -> Left errorUnknownMethod
        Just ifaceName -> case Data.Map.lookup ifaceName obj of
            Nothing -> Left errorUnknownInterface
            Just iface -> case Data.Map.lookup (methodCallMember msg) iface of
                Just (MethodInfo _ _ io) -> Right io
                _ -> Left errorUnknownMethod

introspectRoot :: Client -> Method
introspectRoot client = methodIntrospect $ do
    objects <- readIORef (clientObjects client)
    let paths = filter (/= "/") (Data.Map.keys objects)
    return (I.object "/")
        { I.objectInterfaces =
            [ (I.interface interfaceIntrospectable)
                { I.interfaceMethods =
                    [ (I.method "Introspect")
                        { I.methodArgs =
                            [ I.methodArg "" TypeString I.directionOut
                            ]
                        }
                    ]
                }
            ]
        , I.objectChildren = [I.object p | p <- paths]
        }

methodIntrospect :: IO I.Object -> Method
methodIntrospect get = method interfaceIntrospectable "Introspect" "" "s" $
    \msg -> case methodCallBody msg of
        [] -> do
            obj <- get
            let Just xml = I.formatXML obj
            return (replyReturn [toVariant xml])
        _ -> return (replyError errorInvalidParameters [])

introspect :: ObjectPath -> ObjectInfo -> I.Object
introspect path obj = (I.object path) { I.objectInterfaces = interfaces } where
    interfaces = map introspectIface (Data.Map.toList obj)

    introspectIface (name, iface) = (I.interface name)
        { I.interfaceMethods = concatMap introspectMethod (Data.Map.toList iface)
        }

    args inSig outSig =
        map (introspectArg I.directionIn) (signatureTypes inSig) ++
        map (introspectArg I.directionOut) (signatureTypes outSig)

    introspectMethod (name, MethodInfo inSig outSig _) =
        [ (I.method name)
            { I.methodArgs = args inSig outSig
            }
        ]

    introspectArg dir t = I.methodArg "" t dir

-- | Used to automatically generate method signatures for introspection
-- documents. To support automatic signatures, a method's parameters and
-- return value must all be instances of 'IsValue'.
--
-- This class maps Haskell idioms to D-Bus; it is therefore unable to
-- generate some signatures. In particular, it does not support methods
-- which accept/return a single structure, or single-element structures.
-- It also cannot generate signatures for methods with parameters or return
-- values which are only instances of 'IsVariant'. For these cases, please
-- use 'DBus.Client.method'.
--
-- To match common Haskell use, if the return value is a tuple, it will be
-- converted to a list of return values.
class AutoMethod a where
    funTypes :: a -> ([Type], [Type])
    apply :: a -> [Variant] -> Maybe (IO [Variant])

instance AutoMethod (IO ()) where
    funTypes _ = ([], [])

    apply io [] = Just (io >> return [])
    apply _ _ = Nothing

instance IsValue a => AutoMethod (IO a) where
    funTypes io = cased where
        cased = ([], case ioT io undefined of
            (_, t) -> case t of
                TypeStructure ts -> ts
                _ -> [t])

        ioT :: IsValue a => IO a -> a -> (a, Type)
        ioT _ a = (a, typeOf a)

    apply io [] = Just (do
        var <- fmap toVariant io
        case fromVariant var of
            Just struct -> return (structureItems struct)
            Nothing -> return [var])
    apply _ _ = Nothing

instance (IsValue a, AutoMethod fn) => AutoMethod (a -> fn) where
    funTypes fn = cased where
        cased = case valueT undefined of
            (a, t) -> case funTypes (fn a) of
                (ts, ts') -> (t : ts, ts')

        valueT :: IsValue a => a -> (a, Type)
        valueT a = (a, typeOf a)

    apply _ [] = Nothing
    apply fn (v:vs) = case fromVariant v of
        Just v' -> apply (fn v') vs
        Nothing -> Nothing

-- | Prepare a Haskell function for export, automatically detecting the
-- function's type signature.
--
-- See 'AutoMethod' for details on the limitations of this function.
--
-- See 'method' for exporting functions with user-defined types.
autoMethod :: (AutoMethod fn) => InterfaceName -> MemberName -> fn -> Method
autoMethod iface name fun = DBus.Client.method iface name inSig outSig io where
    (typesIn, typesOut) = funTypes fun
    inSig = case signature typesIn of
        Just sig -> sig
        Nothing -> invalid "input"
    outSig = case signature typesOut of
        Just sig -> sig
        Nothing -> invalid "output"
    io msg = case apply fun (methodCallBody msg) of
        Nothing -> return (ReplyError errorInvalidParameters [])
        Just io' -> fmap ReplyReturn io'

    invalid label = error (concat
        [ "Method "
        , formatInterfaceName iface
        , "."
        , formatMemberName name
        , " has an invalid "
        , label
        , " signature."])

errorFailed :: ErrorName
errorFailed = errorName_ "org.freedesktop.DBus.Error.Failed"

errorDisconnected :: ErrorName
errorDisconnected = errorName_ "org.freedesktop.DBus.Error.Disconnected"

errorUnknownObject :: ErrorName
errorUnknownObject = errorName_ "org.freedesktop.DBus.Error.UnknownObject"

errorUnknownInterface :: ErrorName
errorUnknownInterface = errorName_ "org.freedesktop.DBus.Error.UnknownInterface"

errorUnknownMethod :: ErrorName
errorUnknownMethod = errorName_ "org.freedesktop.DBus.Error.UnknownMethod"

errorInvalidParameters :: ErrorName
errorInvalidParameters = errorName_ "org.freedesktop.DBus.Error.InvalidParameters"

dbusName :: BusName
dbusName = busName_ "org.freedesktop.DBus"

dbusPath :: ObjectPath
dbusPath = objectPath_ "/org/freedesktop/DBus"

dbusInterface :: InterfaceName
dbusInterface = interfaceName_ "org.freedesktop.DBus"

interfaceIntrospectable :: InterfaceName
interfaceIntrospectable = interfaceName_ "org.freedesktop.DBus.Introspectable"

atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ ref fn = atomicModifyIORef ref (\x -> (fn x, ()))

#if !MIN_VERSION_base(4,6,0)
atomicWriteIORef :: IORef a -> a -> IO ()
atomicWriteIORef ref x = atomicModifyIORef ref (\_ -> (x, ()))
#endif
