dbus-core-0.8.3: src/name-reservation.anansi

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

\section{Name reservation}

The central bus allows clients to register a well-known bus name, which
enables other clients to connect with or start a particular application.

:f DBus/NameReservation.hs
|copyright|
{-# LANGUAGE OverloadedStrings #-}
module DBus.NameReservation
	( RequestNameFlag (..)
	, RequestNameReply (..)
	, ReleaseNameReply (..)
	, requestName
	, releaseName
	, mkRequestNameReply
	, mkReleaseNameReply
	) where
import Data.Word (Word32)
import Data.Bits ((.|.))
import qualified Data.Set as Set
import qualified DBus.Types as T
import qualified DBus.Message as M
import qualified DBus.Constants as C
import DBus.Util (maybeIndex)
:

:f DBus/NameReservation.hs
data RequestNameFlag
	= AllowReplacement
	| ReplaceExisting
	| DoNotQueue
	deriving (Show)
:

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

There are only two methods of interest here, {\tt RequestName} and
{\tt ReleaseName}.

:f DBus/NameReservation.hs
|apidoc requestName|
requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall
requestName name flags = M.MethodCall
	{ M.methodCallPath = C.dbusPath
	, M.methodCallInterface = Just C.dbusInterface
	, M.methodCallDestination = Just C.dbusName
	, M.methodCallFlags = Set.empty
	, M.methodCallMember = "RequestName"
	, M.methodCallBody =
		[ T.toVariant name
		, T.toVariant . encodeFlags $ flags]
	}
:

:f DBus/NameReservation.hs
data RequestNameReply
	= PrimaryOwner
	| InQueue
	| Exists
	| AlreadyOwner
	deriving (Show)
:

:f DBus/NameReservation.hs
mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply
mkRequestNameReply msg =
	maybeIndex (M.messageBody msg) 0 >>=
	T.fromVariant >>=
	decodeRequestReply
:

:f DBus/NameReservation.hs
decodeRequestReply :: Word32 -> Maybe RequestNameReply
decodeRequestReply 1 = Just PrimaryOwner
decodeRequestReply 2 = Just InQueue
decodeRequestReply 3 = Just Exists
decodeRequestReply 4 = Just AlreadyOwner
decodeRequestReply _ = Nothing
:

:f DBus/NameReservation.hs
|apidoc releaseName|
releaseName :: T.BusName -> M.MethodCall
releaseName name = M.MethodCall
	{ M.methodCallPath = C.dbusPath
	, M.methodCallInterface = Just C.dbusInterface
	, M.methodCallDestination = Just C.dbusName
	, M.methodCallFlags = Set.empty
	, M.methodCallMember = "ReleaseName"
	, M.methodCallBody = [T.toVariant name]
	}
:

:f DBus/NameReservation.hs
data ReleaseNameReply
	= Released
	| NonExistent
	| NotOwner
	deriving (Show)
:

:f DBus/NameReservation.hs
mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply
mkReleaseNameReply msg =
	maybeIndex (M.messageBody msg) 0 >>=
	T.fromVariant >>=
	decodeReleaseReply
:

:f DBus/NameReservation.hs
decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply
decodeReleaseReply 1 = Just Released
decodeReleaseReply 2 = Just NonExistent
decodeReleaseReply 3 = Just NotOwner
decodeReleaseReply _ = Nothing
: