NameReservation.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.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