{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

module MusicScroll.DBusSignals
  ( mediaPropChangeRule,
    waitForChange,
    changeMusicClient,
  )
where

import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVar, putTMVar, takeTMVar)
import Control.Monad.State.Class (MonadState (..))
import DBus
import DBus.Client
import Data.Foldable (find)
import Data.Maybe (fromJust)
import MusicScroll.ConnState
import MusicScroll.DBusNames
import Pipes

mediaPropChangeRule, busNameAddedRule :: MatchRule
mediaPropChangeRule :: MatchRule
mediaPropChangeRule =
  MatchRule
matchAny
    { matchPath :: Maybe ObjectPath
matchPath = ObjectPath -> Maybe ObjectPath
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ObjectPath
mediaObject,
      matchInterface :: Maybe InterfaceName
matchInterface = InterfaceName -> Maybe InterfaceName
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InterfaceName
"org.freedesktop.DBus.Properties",
      matchMember :: Maybe MemberName
matchMember = MemberName -> Maybe MemberName
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MemberName
"PropertiesChanged"
    }
busNameAddedRule :: MatchRule
busNameAddedRule =
  MatchRule
matchAny
    { matchSender :: Maybe BusName
matchSender = BusName -> Maybe BusName
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BusName
dbusBus, -- unique name
      matchPath :: Maybe ObjectPath
matchPath = ObjectPath -> Maybe ObjectPath
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ObjectPath
"/org/freedesktop/DBus",
      matchInterface :: Maybe InterfaceName
matchInterface = InterfaceName -> Maybe InterfaceName
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InterfaceName
"org.freedesktop.DBus",
      matchMember :: Maybe MemberName
matchMember = MemberName -> Maybe MemberName
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MemberName
"NameOwnerChanged"
    }

waitForChange :: (MonadState ConnState m, MonadIO m) => MatchRule -> m ()
waitForChange :: forall (m :: * -> *).
(MonadState ConnState m, MonadIO m) =>
MatchRule -> m ()
waitForChange MatchRule
rule = do
  (ConnState Client
client BusName
_) <- m ConnState
forall s (m :: * -> *). MonadState s m => m s
get
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    TMVar ()
trigger <- STM (TMVar ()) -> IO (TMVar ())
forall a. STM a -> IO a
atomically STM (TMVar ())
forall a. STM (TMVar a)
newEmptyTMVar
    SignalHandler
disarmHandler <- Client -> TMVar () -> MatchRule -> IO SignalHandler
armSignal Client
client TMVar ()
trigger MatchRule
rule
    ()
_ <- STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
trigger
    Client -> SignalHandler -> IO ()
removeMatch Client
client SignalHandler
disarmHandler

armSignal :: Client -> TMVar () -> MatchRule -> IO SignalHandler
armSignal :: Client -> TMVar () -> MatchRule -> IO SignalHandler
armSignal Client
client TMVar ()
trigger MatchRule
rule =
  Client -> MatchRule -> (Signal -> IO ()) -> IO SignalHandler
addMatch Client
client MatchRule
rule (\Signal
_ -> STM () -> IO ()
forall a. STM a -> IO a
atomically (TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
trigger ()))

changeMusicClient :: (MonadState ConnState m, MonadIO m) => m ()
changeMusicClient :: forall (m :: * -> *). (MonadState ConnState m, MonadIO m) => m ()
changeMusicClient =
  do
    (ConnState Client
client BusName
_) <- m ConnState
forall s (m :: * -> *). MonadState s m => m s
get
    [Bool]
availableStatus <- IO [Bool] -> m [Bool]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Bool] -> m [Bool]) -> IO [Bool] -> m [Bool]
forall a b. (a -> b) -> a -> b
$ (BusName -> IO Bool) -> [BusName] -> IO [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Client -> BusName -> IO Bool
checkName Client
client) [BusName]
allBuses
    let taggedBuses :: [(BusName, Bool)]
taggedBuses = [BusName] -> [Bool] -> [(BusName, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [BusName]
allBuses [Bool]
availableStatus
    case (BusName, Bool) -> BusName
forall a b. (a, b) -> a
fst ((BusName, Bool) -> BusName)
-> Maybe (BusName, Bool) -> Maybe BusName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((BusName, Bool) -> Bool)
-> [(BusName, Bool)] -> Maybe (BusName, Bool)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (BusName, Bool) -> Bool
forall a b. (a, b) -> b
snd [(BusName, Bool)]
taggedBuses of
      Just BusName
newBus -> ConnState -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Client -> BusName -> ConnState
ConnState Client
client BusName
newBus)
      Maybe BusName
Nothing -> do
        MatchRule -> m ()
forall (m :: * -> *).
(MonadState ConnState m, MonadIO m) =>
MatchRule -> m ()
waitForChange MatchRule
busNameAddedRule
        m ()
forall (m :: * -> *). (MonadState ConnState m, MonadIO m) => m ()
changeMusicClient

checkName :: Client -> BusName -> IO Bool
checkName :: Client -> BusName -> IO Bool
checkName Client
client BusName
name = do
  MethodReturn
returnCall <-
    Client -> MethodCall -> IO MethodReturn
call_
      Client
client
      (ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCall ObjectPath
"/org/freedesktop/DBus" InterfaceName
"org.freedesktop.DBus" MemberName
"NameHasOwner")
        { methodCallDestination :: Maybe BusName
methodCallDestination = BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
dbusBus,
          methodCallBody :: [Variant]
methodCallBody = [BusName -> Variant
forall a. IsVariant a => a -> Variant
toVariant BusName
name]
        }
  -- We assume this call is correct, as it's done to the master dbus
  -- object. So fromJust/head are safe.
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool)
-> (MethodReturn -> Bool) -> MethodReturn -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Bool -> Bool
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Bool -> Bool)
-> (MethodReturn -> Maybe Bool) -> MethodReturn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variant -> Maybe Bool
forall a. IsVariant a => Variant -> Maybe a
fromVariant (Variant -> Maybe Bool)
-> (MethodReturn -> Variant) -> MethodReturn -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Variant] -> Variant
forall a. HasCallStack => [a] -> a
head ([Variant] -> Variant)
-> (MethodReturn -> [Variant]) -> MethodReturn -> Variant
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MethodReturn -> [Variant]
methodReturnBody (MethodReturn -> IO Bool) -> MethodReturn -> IO Bool
forall a b. (a -> b) -> a -> b
$ MethodReturn
returnCall