{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
module DBus.MessageBus where

import           Control.Monad.Trans (MonadIO)
import           DBus.Message
import           DBus.Object
import           DBus.Types
import           Data.Conduit (MonadThrow, monadThrow)
import           Data.Default
import           Data.Singletons
import qualified Data.Text as Text
import           Data.Word

import DBus.Error

messageBusMethod :: ( MonadIO m
                    , MonadThrow m
                    , Representable a
                    , SingI (RepType a)
                    ) =>
                    Text.Text
                 -> [SomeDBusValue]
                 -> DBusConnection
                 -> m a
messageBusMethod name args = callMethod' "org.freedesktop.DBus"
                                 (objectPath "/org/freedesktop/DBus")
                                 "org.freedesktop.DBus" name args []

hello :: (MonadIO m, MonadThrow m) => DBusConnection -> m Text.Text
hello = messageBusMethod "Hello" []

data RequestNameFlag = RequestNameFlag { allowReplacement
                                      , replaceExisting
                                      , doNotQueue :: Bool
                                      }

instance Default RequestNameFlag where
    def = RequestNameFlag False False False

fromRequestNameFlags flags = sum [ fromFlag allowReplacement 0x01
                                 , fromFlag replaceExisting  0x02
                                 , fromFlag doNotQueue       0x04
                                 ]
  where
    fromFlag x n = if x flags then n else 0

data RequestNameReply = PrimaryOwner
                      | InQueue
                      | Exists
                      | AlreadyOwner

requestName :: (MonadIO m, MonadThrow m) =>
               Text.Text
            -> RequestNameFlag
            -> DBusConnection
            -> m RequestNameReply
requestName name flags con = do
    reply <- messageBusMethod "RequestName" [ DBV $ DBVString name
                                            , DBV . DBVUInt32 $
                                               fromRequestNameFlags flags]
                                            con
    case reply :: Word32 of
        1 -> return PrimaryOwner
        2 -> return InQueue
        3 -> return Exists
        4 -> return AlreadyOwner
        e -> monadThrow . MarshalError $ "Not a ReqeustName reply: " ++ show e

data ReleaseNameReply = Released
                      | NonExistent
                      | NotOwner

releaseName :: (MonadIO m, MonadThrow m) =>
               Text.Text
            -> DBusConnection
            -> m ReleaseNameReply
releaseName name con = do
        reply <- messageBusMethod "RequestName" [DBV $ DBVString name] con
        case reply :: Word32 of
            1 -> return Released
            2 -> return NonExistent
            3 -> return NotOwner
            e -> monadThrow . MarshalError $ "Not a ReleaseName reply: " ++ show e

listQueuedOwners :: (MonadIO m, MonadThrow m) =>
                    Text.Text
                 -> DBusConnection
                 -> m [Text.Text]
listQueuedOwners name = messageBusMethod "ListQueuedOwners" [DBV $ DBVString name]


listNames :: (MonadIO m, MonadThrow m) => DBusConnection -> m [Text.Text]
listNames = messageBusMethod "ListNames" []

listActivatableNames :: (MonadIO m, MonadThrow m) =>
                        DBusConnection
                     -> m [Text.Text]
listActivatableNames = messageBusMethod "ListActivatableNames" []

nameHasOwner :: (MonadIO m, MonadThrow m) => Text.Text -> DBusConnection -> m Bool
nameHasOwner name = messageBusMethod "NameHasOwner" [DBV $ toRep name]

data StartServiceResult = StartServiceSuccess
                        | StartServiceAlreadyRunning
                          deriving (Show, Read, Eq)

startServiceByName :: (MonadIO m, MonadThrow m) =>
                      Text.Text
                   -> DBusConnection
                   -> m StartServiceResult
startServiceByName name con = do
    res <- messageBusMethod "StartServiceByName"
                            [DBV $ toRep name, DBV $ DBVUInt32 0]
                            con
    return $ case (res :: Word32) of
        1 -> StartServiceSuccess
        2 -> StartServiceAlreadyRunning

getNameOwner :: (MonadIO m, MonadThrow m) =>
                Text.Text
             -> DBusConnection
             -> m Text.Text
getNameOwner txt = messageBusMethod "GetNameOwner" [DBV $ DBVString txt]

getConnectionUnixUser :: (MonadIO m, MonadThrow m) =>
                Text.Text
             -> DBusConnection
             -> m Word32
getConnectionUnixUser txt = messageBusMethod "GetConnectionUnixUser"
                                             [DBV $ DBVString txt]

getConnectionProcessID :: (MonadIO m, MonadThrow m) =>
                Text.Text
             -> DBusConnection
             -> m Word32
getConnectionProcessID txt = messageBusMethod "GetConnectionUnixProcessID"
                                              [DBV $ DBVString txt]

getID :: (MonadIO m, MonadThrow m) =>
         DBusConnection
      -> m Text.Text
getID = messageBusMethod "GetId" []