{-
  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 ())

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

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 (T.mkObjectPath' "/") 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 ())

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 ()

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

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 ()

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

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

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

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

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

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 = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable"
        memberName = T.mkMemberName' "Introspect"
        inSig = T.mkSignature' ""
        outSig = T.mkSignature' "s"
        interface = Interface $ Map.fromList [(memberName, impl)]
        
        method = I.Method memberName [] [I.Parameter "xml" outSig]
        iface = I.Interface ifaceName [method] [] []
        path = T.mkObjectPath' "/"
        
        impl = Method inSig outSig $ \call' -> do
                let Client _ _ _ mvar _ = methodCallClient call'
                paths <- fmap Map.keys $ MV.readMVar mvar
                
                let paths' = filter (/= path) paths
                let Just xml = I.toXML $ I.Object path [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 :: 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 = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable"
        iface = Interface $ Map.fromList [(T.mkMemberName' "Introspect", impl)]
        impl = Method (T.mkSignature' "") (T.mkSignature' "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
                

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

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