{-
  Copyright (C) 2009 John Millikin <jmillikin@gmail.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/>.
-}

{-# LANGUAGE OverloadedStrings #-}
module DBus.Client
        (   -- * Clients
            Client
          , clientName

          , mkClient

            -- ** Sending messages
          , call
          , callBlocking
          , callBlocking_

            -- *** Emitting signals
          , emitSignal

            -- * Name reservation
          , requestName
          , releaseName

            -- * Receiving signals
          , onSignal

            -- * Remote objects and proxies
          , RemoteObject (..)
          , Proxy (..)

          , callProxy
          , callProxyBlocking
          , callProxyBlocking_

          , onSignalFrom

            -- * Exporting local objects
          , LocalObject (..)
          , Interface (..)
          , Member (..)
          , export

            -- ** Responding to method calls
          , MethodCall (..)
          , replyReturn
          , replyError

        ) where
import qualified Control.Concurrent.MVar as MV
import qualified Data.Map as Map
import qualified DBus.Connection as C
import qualified DBus.Message as M
import qualified DBus.Types as T

import Control.Concurrent (forkIO)
import Control.Monad (forever)
import qualified Data.Set as Set
import qualified DBus.Constants as Const

import Data.Maybe (isJust)

import qualified DBus.NameReservation as NR

import qualified DBus.MatchRule as MR
import Data.Maybe (fromJust)

import qualified DBus.Introspection as I

import qualified Data.Text.Lazy as TL


type Callback = (M.ReceivedMessage -> IO ())

-- | 'Client's are opaque handles to an open connection and other internal
-- state.
data Client = Client C.Connection T.BusName
        (MV.MVar (Map.Map M.Serial Callback))
        (MV.MVar (Map.Map T.ObjectPath Callback))
        (MV.MVar [Callback])

clientConnection :: Client -> C.Connection
clientConnection (Client x _ _ _ _) = x

clientName :: Client -> T.BusName
clientName (Client _ x _ _ _) = x

-- | Create a new 'Client' from an open connection and bus name. The weird

-- signature allows 'mkClient' to use the computations in "DBus.Bus"
-- directly, without unpacking:
-- 
-- @
-- client <- mkClient =<< getSessionBus
-- @
-- 
-- Only one client should be created for any given connection. Otherwise,
-- they will compete to receive messages.
-- 
mkClient :: (C.Connection, T.BusName) -> IO Client
mkClient (c, name) = do
        replies <- MV.newMVar Map.empty
        exports <- MV.newMVar Map.empty
        signals <- MV.newMVar []
        let client = Client c name replies exports signals
        forkIO $ forever (receiveMessages client)

        export client ("/") rootObject

        return client

send_ :: M.Message a => Client -> (M.Serial -> IO b) -> a -> IO b
send_ c f msg = do
        result <- C.send (clientConnection c) f msg
        case result of
                Left x -> error $ show x
                Right x -> return x

sendOnly_ :: M.Message a => Client -> a -> IO ()
sendOnly_ c = send_ c (const $ return ())

-- | Perform an asynchronous method call. One of the provided computations
-- will be performed depending on what message type the destination sends
-- back.
-- 
call :: Client -> M.MethodCall
     -> (M.Error -> IO ())
     -> (M.MethodReturn -> IO ())
     -> IO ()
call client msg onError onReturn = send_ client addCallback msg where
        Client _ _ mvar _ _ = client
        addCallback s = MV.modifyMVar_ mvar $ return . Map.insert s callback
        
        callback (M.ReceivedError        _ _ msg') = onError msg'
        callback (M.ReceivedMethodReturn _ _ msg') = onReturn msg'
        callback _ = return ()

-- | Similar to 'call', except that it waits for the reply and returns it
-- in the current 'IO' thread.
-- 
callBlocking :: Client -> M.MethodCall -> IO (Either M.Error M.MethodReturn)
callBlocking client msg = do
        mvar <- MV.newEmptyMVar
        call client msg
                (MV.putMVar mvar . Left)
                (MV.putMVar mvar . Right)
        MV.takeMVar mvar

-- | Similar to 'callBlocking', except that an exception is raised if the
-- destination sends back an error.
-- 
callBlocking_ :: Client -> M.MethodCall -> IO M.MethodReturn
callBlocking_ client msg = do
        reply <- callBlocking client msg
        case reply of
                Left x -> error . TL.unpack . M.errorMessage $ x
                Right x -> return x

emitSignal :: Client -> M.Signal -> IO ()
emitSignal = sendOnly_

receiveMessages :: Client -> IO ()
receiveMessages client = do
        received <- C.receive $ clientConnection client
        case received of
                Left x -> error $ show x
                Right x -> handleMessage client x

handleMessage :: Client -> M.ReceivedMessage -> IO ()
handleMessage client msg@(M.ReceivedMethodCall _ _ call') = do
        let Client _ _ _ mvar _ = client
        objects <- MV.readMVar mvar
        case Map.lookup (M.methodCallPath call') objects of
                Just x  -> x msg
                Nothing -> unknownMethod client msg

handleMessage c msg@(M.ReceivedMethodReturn _ _ msg') =
        gotReply c (M.methodReturnSerial msg') msg
handleMessage c msg@(M.ReceivedError        _ _ msg') =
        gotReply c (M.errorSerial msg') msg

handleMessage c msg@(M.ReceivedSignal _ _ _) = let
        Client _ _ _ _ mvar = c
        in MV.withMVar mvar $ mapM_ (\cb -> forkIO (cb msg))

handleMessage _ _ = return ()

unknownMethod :: Client -> M.ReceivedMessage -> IO ()
unknownMethod client msg = sendOnly_ client errorMsg where
        M.ReceivedMethodCall serial sender _ = msg
        errorMsg = M.Error
                Const.errorUnknownMethod
                serial sender
                []

gotReply :: Client -> M.Serial -> M.ReceivedMessage -> IO ()
gotReply (Client _ _ mvar _ _) serial msg = do
        callback <- MV.modifyMVar mvar $ \callbacks -> let
                x = Map.lookup serial callbacks
                callbacks' = if isJust x
                        then Map.delete serial callbacks
                        else callbacks
                in return (callbacks', x)
        case callback of
                Just x -> forkIO (x msg) >> return ()
                Nothing -> return ()

-- | A client can request a \"well-known\" name from the bus. This allows
-- messages sent to that name to be received by the client, without senders
-- being aware of which application is actually handling requests.
-- 
-- A name may be requested for any client, using the given flags. The bus's
-- reply will be returned, or an exception raised if the reply was invalid.
-- 
requestName :: Client -> T.BusName -> [NR.RequestNameFlag]
            -> IO NR.RequestNameReply
requestName client name flags = do
        reply <- callBlocking_ client $ NR.requestName name flags
        case NR.mkRequestNameReply reply of
                Nothing -> error $ "Invalid reply to RequestName"
                Just x  -> return x

-- | Clients may also release names they've requested.
-- 
releaseName :: Client -> T.BusName -> IO NR.ReleaseNameReply
releaseName client name = do
        reply <- callBlocking_ client $ NR.releaseName name
        case NR.mkReleaseNameReply reply of
                Nothing -> error $ "Invalid reply to ReleaseName"
                Just x  -> return x

-- | Perform some computation every time this client receives a matching
-- signal.
-- 
onSignal :: Client -> MR.MatchRule
         -> (T.BusName -> M.Signal -> IO ())
         -> IO ()
onSignal client rule callback = let
        (Client _ _ _ _ mvar) = client
        rule' = rule { MR.matchType = Just MR.Signal }
        
        callback' msg@(M.ReceivedSignal _ sender signal)
                | MR.matches rule' msg = callback (fromJust sender) signal
        callback' _ = return ()
        
        in do
                callBlocking_ client $ MR.addMatch rule'
                MV.modifyMVar_ mvar $ return . (callback' :)

data RemoteObject = RemoteObject T.BusName T.ObjectPath
data Proxy = Proxy RemoteObject T.InterfaceName

buildMethodCall :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]
                -> M.MethodCall
buildMethodCall proxy name flags body = msg where
        Proxy (RemoteObject dest path) iface = proxy
        msg = M.MethodCall path name (Just iface) (Just dest)
                (Set.fromList flags) body

-- | As 'call', except that the proxy's information is used to
-- build the message.
-- 
callProxy :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]
          -> (M.Error -> IO ())
          -> (M.MethodReturn -> IO ())
          -> IO ()
callProxy client proxy name flags body onError onReturn = let
        msg = buildMethodCall proxy name flags body
        in call client msg onError onReturn

-- | As 'callBlocking', except that the proxy's information is used
-- to build the message.
-- 
callProxyBlocking :: Client -> Proxy -> T.MemberName -> [M.Flag]
                  -> [T.Variant]
                  -> IO (Either M.Error M.MethodReturn)
callProxyBlocking client proxy name flags body =
        callBlocking client $ buildMethodCall proxy name flags body

-- | As 'callBlocking_', except that the proxy's information is used
-- to build the message.
-- 
callProxyBlocking_ :: Client -> Proxy -> T.MemberName -> [M.Flag]
                   -> [T.Variant]
                   -> IO M.MethodReturn
callProxyBlocking_ client proxy name flags body =
        callBlocking_ client $ buildMethodCall proxy name flags body

onSignalFrom :: Client -> Proxy -> T.MemberName -> (M.Signal -> IO ())
             -> IO ()
onSignalFrom client proxy member io = onSignal client rule io' where
        Proxy (RemoteObject dest path) iface = proxy
        rule = MR.MatchRule
                { MR.matchType = Nothing
                , MR.matchSender = Just dest
                , MR.matchInterface = Just iface
                , MR.matchMember = Just member
                , MR.matchPath = Just path
                , MR.matchDestination = Nothing
                , MR.matchParameters = []
                }
        io' _ msg = io msg

rootObject :: LocalObject
rootObject = LocalObject $ Map.fromList [(ifaceName, interface)] where
        ifaceName = "org.freedesktop.DBus.Introspectable"
        memberName =  "Introspect"
        interface = Interface $ Map.fromList [(memberName, impl)]
        
        method = I.Method memberName [] [I.Parameter "xml" "s"]
        iface = I.Interface ifaceName [method] [] []
        
        impl = Method "" "s" $ \call' -> do
                let Client _ _ _ mvar _ = methodCallClient call'
                paths <- fmap Map.keys $ MV.readMVar mvar
                
                let paths' = filter (/= "/") paths
                let Just xml = I.toXML $ I.Object "/" [iface]
                        [I.Object p [] [] | p <- paths']
                replyReturn call' [T.toVariant xml]

newtype LocalObject = LocalObject (Map.Map T.InterfaceName Interface)
newtype Interface = Interface (Map.Map T.MemberName Member)
data Member
        = Method T.Signature T.Signature (MethodCall -> IO ())
        | Signal T.Signature

-- | Export a set of interfaces on the bus. Whenever a method call is
-- received which matches the object's path, interface, and member name,
-- one of its members will be called.
-- 
-- Exported objects automatically implement the
-- @org.freedesktop.DBus.Introspectable@ interface.
-- 
export :: Client -> T.ObjectPath -> LocalObject -> IO ()
export client@(Client _ _ _ mvar _) path obj = MV.modifyMVar_ mvar $
        return . Map.insert path (onMethodCall client (addIntrospectable path obj))

addIntrospectable :: T.ObjectPath -> LocalObject -> LocalObject
addIntrospectable path (LocalObject ifaces) = LocalObject ifaces' where
        ifaces' = Map.insertWith (\_ x -> x) name iface ifaces
        name = "org.freedesktop.DBus.Introspectable"
        iface = Interface $ Map.fromList [("Introspect", impl)]
        impl = Method "" "s" $ \call' -> do
                let Just xml = I.toXML . introspect path . methodCallObject $ call'
                replyReturn call' [T.toVariant xml]

introspect :: T.ObjectPath -> LocalObject -> I.Object
introspect path obj = I.Object path interfaces [] where
        LocalObject ifaceMap = obj
        interfaces = map introspectIface (Map.toList ifaceMap)
        
        introspectIface :: (T.InterfaceName, Interface) -> I.Interface
        introspectIface (name, iface) = I.Interface name methods signals [] where
                Interface memberMap = iface
                members = Map.toList memberMap
                methods = concatMap introspectMethod members
                signals = concatMap introspectSignal members
        
        introspectMethod :: (T.MemberName, Member) -> [I.Method]
        introspectMethod (name, (Method inSig outSig _)) = [I.Method name
                (map introspectParam (T.signatureTypes inSig))
                (map introspectParam (T.signatureTypes outSig))]
        introspectMethod _ = []
        
        introspectSignal :: (T.MemberName, Member) -> [I.Signal]
        introspectSignal (name, (Signal sig)) = [I.Signal name
                (map introspectParam (T.signatureTypes sig))]
        introspectSignal _ = []
        
        introspectParam = I.Parameter "" . T.mkSignature_ . T.typeCode

data MethodCall = MethodCall
        { methodCallObject :: LocalObject
        , methodCallClient :: Client
        , methodCallMethod :: Member
        , methodCallSerial :: M.Serial
        , methodCallSender :: Maybe T.BusName
        , methodCallFlags  :: Set.Set M.Flag
        , methodCallBody   :: [T.Variant]
        }

findMember :: M.MethodCall -> LocalObject -> Maybe Member
findMember call' (LocalObject ifaces) = do
        iface <- M.methodCallInterface call'
        Interface members <- Map.lookup iface ifaces
        Map.lookup (M.methodCallMember call') members

onMethodCall :: Client -> LocalObject -> M.ReceivedMessage -> IO ()
onMethodCall client obj msg = do
        let M.ReceivedMethodCall serial sender call' = msg
            sigStr = TL.concat . map (T.typeCode . T.variantType)
                               . M.methodCallBody $ call'
            sig = T.mkSignature_ sigStr
        
        case findMember call' obj of
                Just method@(Method inSig _ x) -> let
                        call'' = MethodCall obj client method
                                serial sender
                                (M.methodCallFlags call')
                                (M.methodCallBody call')
                        invalidArgs = replyError call'' Const.errorInvalidArgs []
                        in if inSig == sig
                                then x call''
                                else invalidArgs
                _               -> unknownMethod client msg
                

-- | Send a successful return reply for a method call.
-- 
replyReturn :: MethodCall -> [T.Variant] -> IO ()
replyReturn call' body = reply where
        replyInvalid = M.Error
                Const.errorFailed
                (methodCallSerial call')
                (methodCallSender call')
                [T.toVariant $ TL.pack "Method return didn't match signature."]
        
        replyValid = M.MethodReturn
                (methodCallSerial call')
                (methodCallSender call')
                body
        
        sendReply :: M.Message a => a -> IO ()
        sendReply = sendOnly_ (methodCallClient call')
        
        sigStr = TL.concat . map (T.typeCode . T.variantType) $ body
        (Method _ outSig _) = methodCallMethod call'
        reply = if T.mkSignature sigStr == Just outSig
                then sendReply replyValid
                else sendReply replyInvalid

-- | Send an error reply for a method call.
-- 
replyError :: MethodCall -> T.ErrorName -> [T.Variant] -> IO ()
replyError call' name body = sendOnly_ c reply where
        c = methodCallClient call'
        reply = M.Error
                name
                (methodCallSerial call')
                (methodCallSender call')
                body