{-# 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
    , matchPathNamespace

    -- * 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, isPrefixOf)
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           Data.Function

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

    -- | If set, only receives signals sent with the given path or any of
    -- its children.
    , matchPathNamespace :: Maybe ObjectPath
    }

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 "path_namespace" matchPathNamespace formatObjectPath
        ]

    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 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)
    , maybe True (`pathPrefix` signalPath msg) (matchPathNamespace rule)
    ] where
  pathPrefix = isPrefixOf `on` formatObjectPath

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