DBus.hs

-- Author:     Andy Stewart <lazycat.manatee@gmail.com>
-- Maintainer: Andy Stewart <lazycat.manatee@gmail.com>
-- 
-- Copyright (C) 2010 Andy Stewart, all rights reserved.
-- 
-- 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 #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Manatee.Extension.Mplayer.DBus where

import DBus.Client hiding (Signal)
import DBus.MatchRule
import DBus.Message (Signal, signalBody)
import Data.Maybe (fromMaybe)
import Data.Text.Lazy (Text, empty)
import Graphics.UI.Gtk.General.General
import Manatee.Core.DBus
import Manatee.Core.TH
import Manatee.Toolkit.General.DBus
import Manatee.Toolkit.General.Misc
import System.Posix.Process
import System.Posix.Types (ProcessID)
import Data.ByteString (ByteString)

data MplayerDaemonMember = Play
                         | Pause
                         | Stop
                         | Forward
                         | Backward
                         | VolumeInc
                         | VolumeDec
                           deriving (Show, Eq, Ord)

data MplayerDaemonSignalArgs = PlayArgs ByteString ProcessID
                             | PauseArgs
                             | StopArgs
                             | ForwardArgs Int
                             | BackwardArgs Int
                             | VolumeIncArgs Int
                             | VolumeDecArgs Int
                               deriving (Show, Eq, Ord)

data MplayerClientMember = PlayFinished
                         | DaemonProcessStartup
                           deriving (Show, Eq, Ord)

data MplayerClientSignalArgs = PlayFinishedArgs 
                             | DaemonProcessStartupArgs
                             deriving (Show, Eq, Ord)

-- | Mplayer daemon bus name.
mplayerDaemonBusName :: Text
mplayerDaemonBusName = "org.manatee.extension.mplayer.daemon"

mplayerDaemonInterfaceName :: Text 
mplayerDaemonInterfaceName = "org.manatee.daemon.interface"

-- | The daemon path name.
mplayerDaemonPathName :: Text 
mplayerDaemonPathName = "/path"

-- | Check daemon signal argument.
-- Return False if mismatch.
mkFunDec "checkMplayerDaemonSignalArgs" (checkSignalArgs ''MplayerDaemonMember ''MplayerDaemonSignalArgs)

-- | Unpack daemon signal from Variant list.
-- unpackMplayerDaemonSignalArgs_ :: MplayerDaemonMember -> [Variant] -> Maybe MplayerDaemonSignalArgs                 
mkFunDec "unpackMplayerDaemonSignalArgs_" (unpackVariantList ''MplayerDaemonMember ''MplayerDaemonSignalArgs)

-- | Pack daemon signal argument to Variant list.
-- packMplayerDaemonSignalArgs :: MplayerDaemonSignalArgs -> [Variant]
$(packVariantList "packMplayerDaemonSignalArgs" ''MplayerDaemonSignalArgs)

-- | Check client signal argument.
-- Return False if mismatch.
mkFunDec "checkMplayerClientSignalArgs" (checkSignalArgs ''MplayerClientMember ''MplayerClientSignalArgs)

-- | Unpack client signal from Variant list.
-- unpackMplayerClientSignalArgs_ :: MplayerClientMember -> [Variant] -> Maybe MplayerClientSignalArgs                 
mkFunDec "unpackMplayerClientSignalArgs_" (unpackVariantList ''MplayerClientMember ''MplayerClientSignalArgs)

-- | Pack client signal argument to Variant list.
-- packMplayerClientSignalArgs :: MplayerClientSignalArgs -> [Variant]
$(packVariantList "packMplayerClientSignalArgs" ''MplayerClientSignalArgs)

-- | Build daemon signal.
-- If signal argument not match daemon member name.
mkMplayerDaemonSignal :: Client -> MplayerDaemonMember -> MplayerDaemonSignalArgs -> IO ()
mkMplayerDaemonSignal client memberName args 
    | checkMplayerDaemonSignalArgs memberName args -- check signal argument before emit signal.
        = emitSignal client signal
    | otherwise
        = putStrLn $ "mkMplayerDaemonSignal CRITICAL: Invalid argument for dbus daemon member: " ++ show memberName
          where signal = mkMessageSignal 
                         mplayerDaemonPathName
                         (showText memberName)
                         mplayerDaemonInterfaceName
                         mplayerDaemonBusName
                         (packMplayerDaemonSignalArgs args)

-- | Build daemon match rule.
mkMplayerDaemonMatchRule :: Client -> (MplayerDaemonMember, MplayerDaemonSignalArgs -> IO ()) -> IO ()
mkMplayerDaemonMatchRule client (member, fun) = 
    onSignal client matchRule $ \_ signal -> 
        fun $ pickMplayerDaemonSignalArgs member signal
        where matchRule = mkMatchRule
                          (Just Signal) 
                          empty 
                          mplayerDaemonInterfaceName
                          (showText member)
                          mplayerDaemonPathName
                          mplayerDaemonBusName
                          []

-- | Build daemon match rule list.
mkMplayerDaemonMatchRules :: Client -> [(MplayerDaemonMember, MplayerDaemonSignalArgs -> IO ())] -> IO ()              
mkMplayerDaemonMatchRules client = mapM_ (mkMplayerDaemonMatchRule client)

-- | Pick MplayerDaemonSignalArgs.
pickMplayerDaemonSignalArgs :: MplayerDaemonMember -> Signal -> MplayerDaemonSignalArgs          
pickMplayerDaemonSignalArgs member signal = unpackMplayerDaemonSignalArgs member $ signalBody signal

-- | Unpack daemon signal from Variant list.
-- Report error if mismatch.
unpackMplayerDaemonSignalArgs member args = 
    fromMaybe 
      (error $ "unpackMplayerDaemonSignalArgs: Miss pattern for " ++ show member)
      (unpackMplayerDaemonSignalArgs_ member args)

-- | Pick MplayerClientSignalArgs.
pickMplayerClientSignalArgs :: MplayerClientMember -> Signal -> MplayerClientSignalArgs          
pickMplayerClientSignalArgs member signal = unpackMplayerClientSignalArgs member $ signalBody signal

-- | Unpack client signal from Variant list.
-- Report error if mismatch.
unpackMplayerClientSignalArgs member args = 
    fromMaybe 
      (error $ "unpackMplayerClientSignalArgs: Miss pattern for " ++ show member)
      (unpackMplayerClientSignalArgs_ member args)

-- | Build render signal.
-- If signal argument not match render member name.
mkMplayerClientSignal :: Client -> ProcessID -> MplayerClientMember -> MplayerClientSignalArgs -> IO ()
mkMplayerClientSignal client processId memberName args 
    | checkMplayerClientSignalArgs memberName args -- check signal argument before emit signal.
        = emitSignal client signal
    | otherwise
        = putStrLn $ "mkMplayerClientSignal CRITICAL: Invalid argument for dbus render member: " ++ show memberName
          where signal = mkMessageSignal 
                         renderPathName
                         (showText memberName)
                         renderInterfaceName
                         (mkRenderClientName processId)
                         (packMplayerClientSignalArgs args)

-- | Build render process match rule for catch signal.
mkMplayerClientMatchRule :: Client -> (MplayerClientMember, MplayerClientSignalArgs -> IO ()) -> IO ()
mkMplayerClientMatchRule client (member, fun) = do
    processId <- getProcessID
    let matchRule = mkMatchRule 
                          (Just Signal) 
                          empty 
                          renderInterfaceName 
                          (showText member)
                          renderPathName
                          (mkRenderClientName processId)
                          []
    -- Use postGUIAsync wrap DBus action to protect gtk+ main thread. 
    onSignal client matchRule $ \_ signal -> 
        postGUIAsync $ fun $ pickMplayerClientSignalArgs member signal