Client.hs

{-# LANGUAGE TemplateHaskell #-}

-- Copyright (C) 2010-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/>.

module DBusTests.Client (test_Client) where

import           Control.Concurrent
import           Control.Exception (try)
import           Control.Monad.IO.Class (liftIO)
import qualified Data.Map as Map
import           Data.Word

import           Test.Chell

import           DBus
import qualified DBus.Client
import qualified DBus.Socket

import           DBusTests.Util (forkVar, withEnv)

test_Client :: Suite
test_Client = suite "Client" $
	[ test_RequestName
	, test_ReleaseName
	, test_Call
	, test_CallNoReply
	, test_AddMatch
	, test_AutoMethod
	, test_ExportIntrospection
	] ++ suiteTests suite_Connect

test_Connect :: String -> (Address -> IO DBus.Client.Client) -> Test
test_Connect name connect = assertions name $ do
	(addr, sockVar) <- startDummyBus
	clientVar <- forkVar (connect addr)
	
	-- TODO: verify that 'hello' contains expected data, and
	-- send a properly formatted reply.
	sock <- liftIO (readMVar sockVar)
	receivedHello <- liftIO (DBus.Socket.receive sock)
	let (ReceivedMethodCall helloSerial _) = receivedHello
	
	liftIO (DBus.Socket.send sock (methodReturn helloSerial) (\_ -> return ()))
	
	client <- liftIO (readMVar clientVar)
	liftIO (DBus.Client.disconnect client)

suite_Connect :: Suite
suite_Connect = suite "connect"
	[ test_ConnectSystem
	, test_ConnectSystem_NoAddress
	, test_ConnectSession
	, test_ConnectSession_NoAddress
	, test_ConnectStarter
	, test_ConnectStarter_NoAddress
	]

test_ConnectSystem :: Test
test_ConnectSystem = test_Connect "connectSystem" $ \addr -> do
	withEnv "DBUS_SYSTEM_BUS_ADDRESS"
		(Just (formatAddress addr))
		DBus.Client.connectSystem

test_ConnectSystem_NoAddress :: Test
test_ConnectSystem_NoAddress = assertions "connectSystem-no-address" $ do
	$expect $ throwsEq
		(DBus.Client.clientError "connectSystem: DBUS_SYSTEM_BUS_ADDRESS is invalid.")
		(withEnv "DBUS_SYSTEM_BUS_ADDRESS"
			(Just "invalid")
			DBus.Client.connectSystem)

test_ConnectSession :: Test
test_ConnectSession = test_Connect "connectSession" $ \addr -> do
	withEnv "DBUS_SESSION_BUS_ADDRESS"
		(Just (formatAddress addr))
		DBus.Client.connectSession

test_ConnectSession_NoAddress :: Test
test_ConnectSession_NoAddress = assertions "connectSession-no-address" $ do
	$expect $ throwsEq
		(DBus.Client.clientError "connectSession: DBUS_SESSION_BUS_ADDRESS is missing or invalid.")
		(withEnv "DBUS_SESSION_BUS_ADDRESS"
			(Just "invalid")
			DBus.Client.connectSession)

test_ConnectStarter :: Test
test_ConnectStarter = test_Connect "connectStarter" $ \addr -> do
	withEnv "DBUS_STARTER_ADDRESS"
		(Just (formatAddress addr))
		DBus.Client.connectStarter

test_ConnectStarter_NoAddress :: Test
test_ConnectStarter_NoAddress = assertions "connectStarter-no-address" $ do
	$expect $ throwsEq
		(DBus.Client.clientError "connectStarter: DBUS_STARTER_ADDRESS is missing or invalid.")
		(withEnv "DBUS_STARTER_ADDRESS"
			(Just "invalid")
			DBus.Client.connectStarter)

test_RequestName :: Test
test_RequestName = assertions "requestName" $ do
	(sock, client) <- startConnectedClient
	let allFlags =
		[ DBus.Client.nameAllowReplacement
		, DBus.Client.nameReplaceExisting
		, DBus.Client.nameDoNotQueue
		]
	
	let requestCall = (dbusCall "RequestName")
		{ methodCallDestination = Just (busName_ "org.freedesktop.DBus")
		, methodCallBody = [toVariant "com.example.Foo", toVariant (7 :: Word32)]
		}
	
	let requestReply body serial = (methodReturn serial)
		{ methodReturnBody = body
		}
	
	-- NamePrimaryOwner
	do
		reply <- stubMethodCall sock
			(DBus.Client.requestName client (busName_ "com.example.Foo") allFlags)
			requestCall
			(requestReply [toVariant (1 :: Word32)])
		$expect (equal reply DBus.Client.NamePrimaryOwner)
	
	-- NameInQueue
	do
		reply <- stubMethodCall sock
			(DBus.Client.requestName client (busName_ "com.example.Foo") allFlags)
			requestCall
			(requestReply [toVariant (2 :: Word32)])
		$expect (equal reply DBus.Client.NameInQueue)
	
	-- NameExists
	do
		reply <- stubMethodCall sock
			(DBus.Client.requestName client (busName_ "com.example.Foo") allFlags)
			requestCall
			(requestReply [toVariant (3 :: Word32)])
		$expect (equal reply DBus.Client.NameExists)
	
	-- NameAlreadyOwner
	do
		reply <- stubMethodCall sock
			(DBus.Client.requestName client (busName_ "com.example.Foo") allFlags)
			requestCall
			(requestReply [toVariant (4 :: Word32)])
		$expect (equal reply DBus.Client.NameAlreadyOwner)
	
	-- response with empty body
	do
		tried <- stubMethodCall sock
			(try (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags))
			requestCall
			(requestReply [])
		err <- $requireLeft tried
		$expect (equal err (DBus.Client.clientError "requestName: received empty response")
			{ DBus.Client.clientErrorFatal = False
			})
	
	-- response with invalid body
	do
		tried <- stubMethodCall sock
			(try (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags))
			requestCall
			(requestReply [toVariant ""])
		err <- $requireLeft tried
		$expect (equal err (DBus.Client.clientError "requestName: received invalid response code (Variant \"\")")
			{ DBus.Client.clientErrorFatal = False
			})
	
	-- response with unknown result code
	do
		reply <- stubMethodCall sock
			(DBus.Client.requestName client (busName_ "com.example.Foo") allFlags)
			requestCall
			(requestReply [toVariant (5 :: Word32)])
		$expect (equal (show reply) ("UnknownRequestNameReply 5"))

test_ReleaseName :: Test
test_ReleaseName = assertions "releaseName" $ do
	(sock, client) <- startConnectedClient
	
	let requestCall = (dbusCall "ReleaseName")
		{ methodCallDestination = Just (busName_ "org.freedesktop.DBus")
		, methodCallBody = [toVariant "com.example.Foo"]
		}
	
	let requestReply body serial = (methodReturn serial)
		{ methodReturnBody = body
		}
	
	-- NameReleased
	do
		reply <- stubMethodCall sock
			(DBus.Client.releaseName client (busName_ "com.example.Foo"))
			requestCall
			(requestReply [toVariant (1 :: Word32)])
		$expect (equal reply DBus.Client.NameReleased)
	
	-- NameNonExistent
	do
		reply <- stubMethodCall sock
			(DBus.Client.releaseName client (busName_ "com.example.Foo"))
			requestCall
			(requestReply [toVariant (2 :: Word32)])
		$expect (equal reply DBus.Client.NameNonExistent)
	
	-- NameNotOwner
	do
		reply <- stubMethodCall sock
			(DBus.Client.releaseName client (busName_ "com.example.Foo"))
			requestCall
			(requestReply [toVariant (3 :: Word32)])
		$expect (equal reply DBus.Client.NameNotOwner)
	
	-- response with empty body
	do
		tried <- stubMethodCall sock
			(try (DBus.Client.releaseName client (busName_ "com.example.Foo")))
			requestCall
			(requestReply [])
		err <- $requireLeft tried
		$expect (equal err (DBus.Client.clientError "releaseName: received empty response")
			{ DBus.Client.clientErrorFatal = False
			})
	
	-- response with invalid body
	do
		tried <- stubMethodCall sock
			(try (DBus.Client.releaseName client (busName_ "com.example.Foo")))
			requestCall
			(requestReply [toVariant ""])
		err <- $requireLeft tried
		$expect (equal err (DBus.Client.clientError "releaseName: received invalid response code (Variant \"\")")
			{ DBus.Client.clientErrorFatal = False
			})
	
	-- response with unknown result code
	do
		reply <- stubMethodCall sock
			(DBus.Client.releaseName client (busName_ "com.example.Foo"))
			requestCall
			(requestReply [toVariant (5 :: Word32)])
		$expect (equal (show reply) ("UnknownReleaseNameReply 5"))

test_Call :: Test
test_Call = assertions "call" $ do
	(sock, client) <- startConnectedClient
	
	let requestCall = (dbusCall "Hello")
		{ methodCallSender = Just (busName_ "com.example.Foo")
		, methodCallDestination = Just (busName_ "org.freedesktop.DBus")
		, methodCallReplyExpected = False
		, methodCallAutoStart = False
		, methodCallBody = [toVariant "com.example.Foo"]
		}
	
	-- methodCallReplyExpected is forced to True
	do
		response <- stubMethodCall sock
			(DBus.Client.call client requestCall)
			(requestCall
				{ methodCallReplyExpected = True
				})
			methodReturn
		reply <- $requireRight response
		
		$expect (equal reply (methodReturn (methodReturnSerial reply)))

test_CallNoReply :: Test
test_CallNoReply = assertions "callNoReply" $ do
	(sock, client) <- startConnectedClient
	
	let requestCall = (dbusCall "Hello")
		{ methodCallSender = Just (busName_ "com.example.Foo")
		, methodCallDestination = Just (busName_ "org.freedesktop.DBus")
		, methodCallReplyExpected = True
		, methodCallAutoStart = False
		, methodCallBody = [toVariant "com.example.Foo"]
		}
	
	-- methodCallReplyExpected is forced to False
	do
		stubMethodCall sock
			(DBus.Client.callNoReply client requestCall)
			(requestCall
				{ methodCallReplyExpected = False
				})
			methodReturn

test_AddMatch :: Test
test_AddMatch = assertions "addMatch" $ do
	(sock, client) <- startConnectedClient
	
	let matchRule = DBus.Client.matchAny
		{ DBus.Client.matchSender = Just (busName_ "com.example.Foo")
		, DBus.Client.matchDestination = Just (busName_ "com.example.Bar")
		, DBus.Client.matchPath = Just (objectPath_ "/")
		, DBus.Client.matchInterface = Just (interfaceName_ "com.example.Baz")
		, DBus.Client.matchMember = Just (memberName_ "Qux")
		}
	
	-- might as well test this while we're at it
	$expect (equal (show matchRule) "MatchRule \"sender='com.example.Foo',destination='com.example.Bar',path='/',interface='com.example.Baz',member='Qux'\"")
	
	let requestCall = (dbusCall "AddMatch")
		{ methodCallDestination = Just (busName_ "org.freedesktop.DBus")
		, methodCallBody = [toVariant "type='signal',sender='com.example.Foo',destination='com.example.Bar',path='/',interface='com.example.Baz',member='Qux'"]
		}
	
	signalVar <- liftIO newEmptyMVar
	
	-- add a listener for the given signal
	stubMethodCall sock
		(DBus.Client.addMatch client matchRule (putMVar signalVar))
		requestCall
		methodReturn
	
	-- ignored signal
	liftIO (DBus.Socket.send sock
		(signal (objectPath_ "/") (interfaceName_ "com.example.Baz") (memberName_ "Qux"))
		(\_ -> return ()))
	$assert (isEmptyMVar signalVar)
	
	-- matched signal
	let matchedSignal = (signal (objectPath_ "/") (interfaceName_ "com.example.Baz") (memberName_ "Qux"))
		{ signalSender = Just (busName_ "com.example.Foo")
		, signalDestination = Just (busName_ "com.example.Bar")
		}
	liftIO (DBus.Socket.send sock matchedSignal (\_ -> return ()))
	received <- liftIO (takeMVar signalVar)
	$expect (equal received matchedSignal)

test_AutoMethod :: Test
test_AutoMethod = assertions "autoMethod" $ do
	(sock, client) <- startConnectedClient
	
	let methodMax = (\x y -> return (max x y)) :: Word32 -> Word32 -> IO Word32
	
	let methodPair = (\x y -> return (x, y)) :: String -> String -> IO (String, String)
	
	liftIO (DBus.Client.export client (objectPath_ "/")
		[ DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Max") methodMax
		, DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Pair") methodPair
		])
	
	-- valid call to com.example.Foo.Max
	do
		(serial, response) <- callClientMethod sock "/" "com.example.Foo" "Max" [toVariant (2 :: Word32), toVariant (1 :: Word32)]
		$expect (equal response (Right (methodReturn serial)
			{ methodReturnBody = [toVariant (2 :: Word32)]
			}))
	
	-- valid call to com.example.Foo.Pair
	do
		(serial, response) <- callClientMethod sock "/" "com.example.Foo" "Pair" [toVariant "x", toVariant "y"]
		$expect (equal response (Right (methodReturn serial)
			{ methodReturnBody = [toVariant "x", toVariant "y"]
			}))
	
	-- invalid call to com.example.Foo.Max
	do
		(serial, response) <- callClientMethod sock "/" "com.example.Foo" "Max" [toVariant "x", toVariant "y"]
		$expect (equal response (Left (methodError serial (errorName_ "org.freedesktop.DBus.Error.InvalidParameters"))))

test_ExportIntrospection :: Test
test_ExportIntrospection = assertions "exportIntrospection" $ do
	(sock, client) <- startConnectedClient
	
	liftIO (DBus.Client.export client (objectPath_ "/foo")
		[ DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Method1")
		  (undefined :: String -> IO ())
		, DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Method2")
		  (undefined :: String -> IO String)
		, DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Method3")
		  (undefined :: String -> IO (String, String))
		])
	
	let introspect path = do
		(_, response) <- callClientMethod sock path "org.freedesktop.DBus.Introspectable" "Introspect" []
		ret <- $requireRight response
		let body = methodReturnBody ret
		
		$assert (equal (length body) 1)
		let Just xml = fromVariant (head body)
		return xml
	
	root <- introspect "/"
	$expect (equalLines root
		"<!DOCTYPE node PUBLIC '-//freedesktop//DTD D-BUS Object Introspection 1.0//EN' 'http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd'>\n\
		\<node name='/'>\
			\<interface name='org.freedesktop.DBus.Introspectable'>\
				\<method name='Introspect'>\
					\<arg name='' type='s' direction='out'/>\
				\</method>\
			\</interface>\
			\<node name='foo'></node>\
		\</node>")
	
	foo <- introspect "/foo"
	$expect (equalLines foo
		"<!DOCTYPE node PUBLIC '-//freedesktop//DTD D-BUS Object Introspection 1.0//EN' 'http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd'>\n\
		\<node name='/foo'>\
			\<interface name='com.example.Foo'>\
				\<method name='Method1'>\
					\<arg name='' type='s' direction='in'/>\
				\</method>\
				\<method name='Method2'>\
					\<arg name='' type='s' direction='in'/>\
					\<arg name='' type='s' direction='out'/>\
				\</method>\
				\<method name='Method3'>\
					\<arg name='' type='s' direction='in'/>\
					\<arg name='' type='s' direction='out'/>\
					\<arg name='' type='s' direction='out'/>\
				\</method>\
			\</interface>\
			\<interface name='org.freedesktop.DBus.Introspectable'>\
				\<method name='Introspect'>\
					\<arg name='' type='s' direction='out'/>\
				\</method>\
			\</interface>\
		\</node>")

startDummyBus :: Assertions (Address, MVar DBus.Socket.Socket)
startDummyBus = do
	uuid <- liftIO randomUUID
	let Just addr = address "unix" (Map.fromList [("abstract", formatUUID uuid)])
	listener <- liftIO (DBus.Socket.listen addr)
	sockVar <- forkVar (DBus.Socket.accept listener)
	return (DBus.Socket.socketListenerAddress listener, sockVar)

startConnectedClient :: Assertions (DBus.Socket.Socket, DBus.Client.Client)
startConnectedClient = do
	(addr, sockVar) <- startDummyBus
	clientVar <- forkVar (DBus.Client.connect addr)
	
	-- TODO: verify that 'hello' contains expected data, and
	-- send a properly formatted reply.
	sock <- liftIO (readMVar sockVar)
	receivedHello <- liftIO (DBus.Socket.receive sock)
	let (ReceivedMethodCall helloSerial _) = receivedHello
	
	liftIO (DBus.Socket.send sock (methodReturn helloSerial) (\_ -> return ()))
	
	client <- liftIO (readMVar clientVar)
	afterTest (DBus.Client.disconnect client)
	
	return (sock, client)

stubMethodCall :: DBus.Socket.Socket -> IO a -> MethodCall -> (Serial -> MethodReturn) -> Assertions a
stubMethodCall sock io expectedCall respond = do
	var <- forkVar io
	
	receivedCall <- liftIO (DBus.Socket.receive sock)
	let ReceivedMethodCall callSerial call = receivedCall
	$expect (equal expectedCall call)
	
	liftIO (DBus.Socket.send sock (respond callSerial) (\_ -> return ()))
	
	liftIO (takeMVar var)

callClientMethod :: DBus.Socket.Socket -> String -> String -> String -> [Variant] -> Assertions (Serial, Either MethodError MethodReturn)
callClientMethod sock path iface name body = do
	let call = (methodCall (objectPath_ path) (interfaceName_ iface) (memberName_ name))
		{ methodCallBody = body
		}
	serial <- liftIO (DBus.Socket.send sock call return)
	resp <- liftIO (DBus.Socket.receive sock)
	case resp of
		ReceivedMethodReturn _ ret -> return (serial, Right ret)
		ReceivedMethodError _ err -> return (serial, Left err)
		_ -> $die "callClientMethod: unexpected response to method call"

dbusCall :: String -> MethodCall
dbusCall member = methodCall (objectPath_ "/org/freedesktop/DBus") (interfaceName_ "org.freedesktop.DBus") (memberName_ member)