-- 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/>.
{-# 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)
data RequestNameFlag
	= AllowReplacement
	| ReplaceExisting
	| DoNotQueue
	deriving (Show)
encodeFlags :: [RequestNameFlag] -> Word32
encodeFlags = foldr (.|.) 0 . map flagValue where
	flagValue AllowReplacement = 0x1
	flagValue ReplaceExisting  = 0x2
	flagValue DoNotQueue       = 0x4
-- | Build a 'M.MethodCall' for requesting a registered bus name.
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]
	}
data RequestNameReply
	= PrimaryOwner
	| InQueue
	| Exists
	| AlreadyOwner
	deriving (Show)
mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply
mkRequestNameReply msg =
	maybeIndex (M.messageBody msg) 0 >>=
	T.fromVariant >>=
	decodeRequestReply
decodeRequestReply :: Word32 -> Maybe RequestNameReply
decodeRequestReply 1 = Just PrimaryOwner
decodeRequestReply 2 = Just InQueue
decodeRequestReply 3 = Just Exists
decodeRequestReply 4 = Just AlreadyOwner
decodeRequestReply _ = Nothing
-- | Build a 'M.MethodCall' for releasing a registered bus name.
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]
	}
data ReleaseNameReply
	= Released
	| NonExistent
	| NotOwner
	deriving (Show)
mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply
mkReleaseNameReply msg =
	maybeIndex (M.messageBody msg) 0 >>=
	T.fromVariant >>=
	decodeReleaseReply
decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply
decodeReleaseReply 1 = Just Released
decodeReleaseReply 2 = Just NonExistent
decodeReleaseReply 3 = Just NotOwner
decodeReleaseReply _ = Nothing