Client.hs

{-
  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
        (   Client
          , clientConnection

          , mkClient

          , RequestNameFlag (..)
          , RequestNameReply (..)
          , ReleaseNameReply (..)

          , requestName

          , releaseName

          , onSignal
          , signalFilter

          , RemoteObject (..)
          , Proxy (..)
          , call
          , callBlocking
          , onSignalFrom

          , LocalObject (..)
          , Member (..)
          , Interface (..)
          , MethodCall (..)
          , export

          , 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.Constants as Const
import qualified DBus.Message as M
import qualified DBus.Types as T

import Data.Word (Word32)
import Data.Bits ((.|.))

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

import Data.Maybe (isJust, fromJust, isNothing)

import qualified DBus.Introspection as I

import qualified Data.Text.Lazy as TL


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

data Client = Client C.Connection
        (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

mkClient :: IO (C.Connection, T.BusName) -> IO Client
mkClient getBus = do
        (c, _) <- getBus
        replies <- MV.newMVar Map.empty
        exports <- MV.newMVar Map.empty
        signals <- MV.newMVar []
        let client = Client c replies exports signals
        forkIO $ forever (receiveMessages client)

        export client (T.mkObjectPath' "/") rootObject

        return client

send' :: M.Message a => C.Connection -> (M.Serial -> IO b) -> a
      -> IO b
send' c f msg = C.send c f msg >>= \result -> case result of
        Left x -> error $ show x
        Right x -> return x

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

data RequestNameReply
        = PrimaryOwner
        | InQueue
        | Exists
        | AlreadyOwner
        deriving (Show)

data ReleaseNameReply
        = Released
        | NonExistent
        | NotOwner
        deriving (Show)

dbus :: Proxy
dbus = Proxy (RemoteObject Const.dbusName Const.dbusPath) Const.dbusInterface

request, release :: T.MemberName
request = T.mkMemberName' "RequestName"
release = T.mkMemberName' "ReleaseName"

requestName :: Client -> T.BusName -> [RequestNameFlag] -> IO RequestNameReply
requestName client name flags = do
        returned <- callBlocking client dbus request []
                [ T.toVariant name
                , T.toVariant . encodeFlags $ flags]
        
        let reply = M.messageBody returned !! 0
        case decodeRequestReply =<< T.fromVariant reply of
                Just x  -> return x
                Nothing -> error $ "Unknown request name reply: " ++
                                   show reply

releaseName :: Client -> T.BusName -> IO ReleaseNameReply
releaseName client name = do
        returned <- callBlocking client dbus release [] [T.toVariant name]
        
        let reply = M.messageBody returned !! 0
        case decodeReleaseReply =<< T.fromVariant reply of
                Just x  -> return x
                Nothing -> error $ "Unknown release name reply: " ++
                                   show reply

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

decodeRequestReply :: Word32 -> Maybe RequestNameReply
decodeRequestReply 1 = Just PrimaryOwner
decodeRequestReply 2 = Just InQueue
decodeRequestReply 3 = Just Exists
decodeRequestReply 4 = Just AlreadyOwner
decodeRequestReply _ = Nothing

decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply
decodeReleaseReply 1 = Just Released
decodeReleaseReply 2 = Just NonExistent
decodeReleaseReply 3 = Just NotOwner
decodeReleaseReply _ = Nothing

receiveMessages :: Client -> IO ()
receiveMessages client@(Client c _ _ _) = do
        received <- C.receive c
        msg <- case received of
                Left x -> error $ show x
                Right x -> return x
        case msg of
                (M.ReceivedMethodCall   _ _ _   ) -> gotMethodCall client msg
                (M.ReceivedMethodReturn _ _ msg') -> gotReply client (M.methodReturnSerial msg') msg
                (M.ReceivedError        _ _ msg') -> gotReply client (M.errorSerial msg') msg
                (M.ReceivedSignal       _ _ _   ) -> gotSignal client msg
                _                                 -> return ()

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

unknownMethod :: Client -> M.ReceivedMessage -> IO ()
unknownMethod client msg = send' c (const $ return ()) errorMsg where
        M.ReceivedMethodCall serial sender _ = msg
        c = clientConnection client
        errorMsg = M.Error
                Const.errorUnknownMethod
                serial sender
                (Set.fromList [M.NoReplyExpected, M.NoAutoStart])
                []

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

gotSignal :: Client -> M.ReceivedMessage -> IO ()
gotSignal (Client _ _ _ mvar) msg = MV.withMVar mvar $
        mapM_ (\cb -> forkIO (cb msg))

onSignal :: Client
            -> (T.BusName -> M.Signal -> Bool)
            -> (T.BusName -> M.Signal -> IO ())
            -> IO ()
onSignal (Client _ _ _ mvar) test callback = MV.modifyMVar_ mvar addCallback where
        addCallback callbacks = return $ callback' : callbacks
        callback' (M.ReceivedSignal _ sender msg) =
                if test (fromJust sender) msg
                        then callback (fromJust sender) msg
                        else return ()
        callback' _ = undefined

signalFilter :: Maybe T.BusName -> Maybe T.ObjectPath -> Maybe T.InterfaceName
             -> Maybe T.MemberName -> T.BusName -> M.Signal -> Bool
signalFilter sender path iface member sender' msg = all id
        [ isNothing sender || sender == Just sender'
        , isNothing path   || path == Just (M.signalPath msg)
        , isNothing iface  || iface == Just (M.signalInterface msg)
        , isNothing member || member == Just (M.signalMember msg)
        ]

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

call :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]
     -> (M.Error -> IO ())
     -> (M.MethodReturn -> IO ())
     -> IO ()
call client proxy name flags body onError onReturn = let
        Proxy (RemoteObject dest path) iface = proxy
        Client bus mvar _ _ = client
        msg = M.MethodCall path name (Just iface) (Just dest)
                (Set.fromList flags)
                body
        
        callback (M.ReceivedError _ _ z) = onError z
        callback (M.ReceivedMethodReturn _ _ z) = onReturn z
        callback _ = undefined
        
        addCallback s = MV.modifyMVar_ mvar $ \callbacks ->
                return $ Map.insert s callback callbacks
        in send' bus addCallback msg

callBlocking :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]
             -> IO M.MethodReturn
callBlocking client proxy name flags body = do
        mvar <- MV.newEmptyMVar
        call client proxy name flags body
                (MV.putMVar mvar . Left)
                (MV.putMVar mvar . Right)
        reply <- MV.takeMVar mvar
        case reply of
                Left x  -> error (show x)
                Right x -> return x

onSignalFrom :: Client -> Proxy -> T.MemberName -> (M.Signal -> IO ())
             -> IO ()
onSignalFrom client proxy member io = onSignal client test io' where
        Proxy (RemoteObject dest path) iface = proxy
        test = signalFilter (Just dest) (Just path) (Just iface)
                            (Just member)
        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
        c = clientConnection . methodCallClient $ call'
        replyInvalid = M.Error
                Const.errorFailed
                (methodCallSerial call')
                (methodCallSender call')
                (Set.fromList [M.NoReplyExpected, M.NoAutoStart])
                [T.toVariant $ TL.pack "Method return didn't match signature."]
        
        replyValid = M.MethodReturn
                (methodCallSerial call')
                (methodCallSender call')
                (Set.fromList [M.NoReplyExpected, M.NoAutoStart])
                body
        
        sendReply :: M.Message a => a -> IO ()
        sendReply = send' c (const $ return ())
        
        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 = send' c (const $ return ()) reply where
        c = clientConnection . methodCallClient $ call'
        reply = M.Error
                name
                (methodCallSerial call')
                (methodCallSender call')
                (Set.fromList [M.NoReplyExpected, M.NoAutoStart])
                body