{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
module StatusNotifier.Host.Service where

import           Control.Applicative
import           Control.Arrow
import           Control.Concurrent
import           Control.Concurrent.MVar
import           Control.Lens
import           Control.Lens.Tuple
import           Control.Monad
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Maybe
import           DBus
import           DBus.Client
import           DBus.Generation
import qualified DBus.Internal.Message as M
import           DBus.Internal.Types
import qualified DBus.TH as DTH
import qualified Data.ByteString as BS
import           Data.Coerce
import           Data.Either
import           Data.Int
import qualified Data.Map.Strict as Map
import           Data.Maybe
import           Data.String
import           Data.Typeable
import           Data.Unique
import           Data.Word
import           System.Log.Logger
import           Text.Printf

import qualified StatusNotifier.Item.Client as I
import           StatusNotifier.Util
import qualified StatusNotifier.Watcher.Client as W
import qualified StatusNotifier.Watcher.Constants as W
import qualified StatusNotifier.Watcher.Signals as W
import qualified StatusNotifier.Watcher.Service as W

statusNotifierHostString :: String
statusNotifierHostString :: String
statusNotifierHostString = String
"StatusNotifierHost"

getBusName :: String -> String -> String
getBusName :: String -> String -> String
getBusName String
namespace =
  String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%s.%s-%s" String
namespace String
statusNotifierHostString

data UpdateType
  = ItemAdded
  | ItemRemoved
  | IconUpdated
  | OverlayIconUpdated
  | StatusUpdated
  | TitleUpdated
  | ToolTipUpdated deriving (UpdateType -> UpdateType -> Bool
(UpdateType -> UpdateType -> Bool)
-> (UpdateType -> UpdateType -> Bool) -> Eq UpdateType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UpdateType -> UpdateType -> Bool
== :: UpdateType -> UpdateType -> Bool
$c/= :: UpdateType -> UpdateType -> Bool
/= :: UpdateType -> UpdateType -> Bool
Eq, Int -> UpdateType -> String -> String
[UpdateType] -> String -> String
UpdateType -> String
(Int -> UpdateType -> String -> String)
-> (UpdateType -> String)
-> ([UpdateType] -> String -> String)
-> Show UpdateType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UpdateType -> String -> String
showsPrec :: Int -> UpdateType -> String -> String
$cshow :: UpdateType -> String
show :: UpdateType -> String
$cshowList :: [UpdateType] -> String -> String
showList :: [UpdateType] -> String -> String
Show)

type UpdateHandler = UpdateType -> ItemInfo -> IO ()

data Params = Params
  { Params -> Maybe Client
dbusClient :: Maybe Client
  , Params -> String
uniqueIdentifier :: String
  , Params -> String
namespace :: String
  , Params -> Bool
startWatcher :: Bool
  , Params -> Bool
matchSenderWhenNameOwnersUnmatched :: Bool
  }

hostLogger :: Priority -> String -> IO ()
hostLogger = String -> Priority -> String -> IO ()
logM String
"StatusNotifier.Host.Service"

defaultParams :: Params
defaultParams = Params
  { dbusClient :: Maybe Client
dbusClient = Maybe Client
forall a. Maybe a
Nothing
  , uniqueIdentifier :: String
uniqueIdentifier = String
""
  , namespace :: String
namespace = String
"org.kde"
  , startWatcher :: Bool
startWatcher = Bool
False
  , matchSenderWhenNameOwnersUnmatched :: Bool
matchSenderWhenNameOwnersUnmatched = Bool
True
  }

type ImageInfo = [(Int32, Int32, BS.ByteString)]

isExpectedPropertyUpdateFailure :: M.MethodError -> Bool
isExpectedPropertyUpdateFailure :: MethodError -> Bool
isExpectedPropertyUpdateFailure M.MethodError { methodErrorName :: MethodError -> ErrorName
M.methodErrorName = ErrorName
errName } =
  ErrorName
errName ErrorName -> ErrorName -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorName
errorUnknownMethod Bool -> Bool -> Bool
||
  ErrorName
errName ErrorName -> ErrorName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ErrorName
errorName_ String
"org.freedesktop.DBus.Error.InvalidArgs"

propertyUpdateFailureLogLevel :: [M.MethodError] -> [a] -> Priority
propertyUpdateFailureLogLevel :: forall a. [MethodError] -> [a] -> Priority
propertyUpdateFailureLogLevel [MethodError]
failures [a]
updates
  | Bool -> Bool
not ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
updates) = Priority
DEBUG
  | (MethodError -> Bool) -> [MethodError] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all MethodError -> Bool
isExpectedPropertyUpdateFailure [MethodError]
failures = Priority
DEBUG
  | Bool
otherwise = Priority
ERROR

data ItemInfo = ItemInfo
  { ItemInfo -> BusName
itemServiceName :: BusName
  , ItemInfo -> ObjectPath
itemServicePath :: ObjectPath
  , ItemInfo -> Maybe String
itemId :: Maybe String
  , ItemInfo -> Maybe String
itemStatus :: Maybe String
  , ItemInfo -> Maybe String
itemCategory :: Maybe String
  , ItemInfo -> Maybe (String, ImageInfo, String, String)
itemToolTip :: Maybe (String, ImageInfo, String, String)
  , ItemInfo -> String
iconTitle :: String
  , ItemInfo -> String
iconName :: String
  , ItemInfo -> Maybe String
overlayIconName :: Maybe String
  , ItemInfo -> Maybe String
iconThemePath :: Maybe String
  , ItemInfo -> ImageInfo
iconPixmaps :: ImageInfo
  , ItemInfo -> ImageInfo
overlayIconPixmaps :: ImageInfo
  , ItemInfo -> Maybe ObjectPath
menuPath :: Maybe ObjectPath
  , ItemInfo -> Bool
itemIsMenu :: Bool
  } deriving (ItemInfo -> ItemInfo -> Bool
(ItemInfo -> ItemInfo -> Bool)
-> (ItemInfo -> ItemInfo -> Bool) -> Eq ItemInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ItemInfo -> ItemInfo -> Bool
== :: ItemInfo -> ItemInfo -> Bool
$c/= :: ItemInfo -> ItemInfo -> Bool
/= :: ItemInfo -> ItemInfo -> Bool
Eq, Int -> ItemInfo -> String -> String
[ItemInfo] -> String -> String
ItemInfo -> String
(Int -> ItemInfo -> String -> String)
-> (ItemInfo -> String)
-> ([ItemInfo] -> String -> String)
-> Show ItemInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ItemInfo -> String -> String
showsPrec :: Int -> ItemInfo -> String -> String
$cshow :: ItemInfo -> String
show :: ItemInfo -> String
$cshowList :: [ItemInfo] -> String -> String
showList :: [ItemInfo] -> String -> String
Show)

supressPixelData :: ItemInfo -> ItemInfo
supressPixelData ItemInfo
info =
  ItemInfo
info { iconPixmaps = map (\(Int32
w, Int32
h, ByteString
_) -> (Int32
w, Int32
h, ByteString
"")) $ iconPixmaps info }

makeLensesWithLSuffix ''ItemInfo

convertPixmapsToHostByteOrder ::
  [(Int32, Int32, BS.ByteString)] -> [(Int32, Int32, BS.ByteString)]
convertPixmapsToHostByteOrder :: ImageInfo -> ImageInfo
convertPixmapsToHostByteOrder = ((Int32, Int32, ByteString) -> (Int32, Int32, ByteString))
-> ImageInfo -> ImageInfo
forall a b. (a -> b) -> [a] -> [b]
map (((Int32, Int32, ByteString) -> (Int32, Int32, ByteString))
 -> ImageInfo -> ImageInfo)
-> ((Int32, Int32, ByteString) -> (Int32, Int32, ByteString))
-> ImageInfo
-> ImageInfo
forall a b. (a -> b) -> a -> b
$ ASetter
  (Int32, Int32, ByteString)
  (Int32, Int32, ByteString)
  ByteString
  ByteString
-> (ByteString -> ByteString)
-> (Int32, Int32, ByteString)
-> (Int32, Int32, ByteString)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (Int32, Int32, ByteString)
  (Int32, Int32, ByteString)
  ByteString
  ByteString
forall s t a b. Field3 s t a b => Lens s t a b
Lens
  (Int32, Int32, ByteString)
  (Int32, Int32, ByteString)
  ByteString
  ByteString
_3 ByteString -> ByteString
networkToSystemByteOrder

callFromInfo :: (BusName -> ObjectPath -> t) -> ItemInfo -> t
callFromInfo BusName -> ObjectPath -> t
fn ItemInfo { itemServiceName :: ItemInfo -> BusName
itemServiceName = BusName
name
                         , itemServicePath :: ItemInfo -> ObjectPath
itemServicePath = ObjectPath
path
                         } = BusName -> ObjectPath -> t
fn BusName
name ObjectPath
path

data Host = Host
  { Host -> IO (Map BusName ItemInfo)
itemInfoMap :: IO (Map.Map BusName ItemInfo)
  , Host -> UpdateHandler -> IO Unique
addUpdateHandler :: UpdateHandler -> IO Unique
  , Host -> Unique -> IO ()
removeUpdateHandler :: Unique -> IO ()
  , Host -> BusName -> IO ()
forceUpdate :: BusName -> IO ()
  } deriving Typeable

build :: Params -> IO (Maybe Host)
build :: Params -> IO (Maybe Host)
build Params { dbusClient :: Params -> Maybe Client
dbusClient = Maybe Client
mclient
             , namespace :: Params -> String
namespace = String
namespaceString
             , uniqueIdentifier :: Params -> String
uniqueIdentifier = String
uniqueID
             , startWatcher :: Params -> Bool
startWatcher = Bool
shouldStartWatcher
             , matchSenderWhenNameOwnersUnmatched :: Params -> Bool
matchSenderWhenNameOwnersUnmatched = Bool
doMatchUnmatchedSender
             } = do
  client <- IO Client -> (Client -> IO Client) -> Maybe Client -> IO Client
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Client
connectSession Client -> IO Client
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Client
mclient
  itemInfoMapVar <- newMVar Map.empty
  updateHandlersVar <- newMVar ([] :: [(Unique, UpdateHandler)])
  let busName = String -> String -> String
getBusName String
namespaceString String
uniqueID

      logError = Priority -> String -> IO ()
hostLogger Priority
ERROR
      logErrorWithMessage String
message a
error = String -> IO ()
logError String
message IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
logError (a -> String
forall a. Show a => a -> String
show a
error)

      logInfo = Priority -> String -> IO ()
hostLogger Priority
INFO
      logDebug = Priority -> String -> IO ()
hostLogger Priority
DEBUG
      logErrorAndThen IO b
andThen a
e = String -> IO ()
logError (a -> String
forall a. Show a => a -> String
show a
e) IO () -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
andThen

      doUpdateForHandler t
utype ItemInfo
uinfo (Unique
unique, t -> ItemInfo -> IO ()
handler) = do
        -- This is extremely chatty under normal operation; keep it at DEBUG.
        String -> IO ()
logDebug (String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Sending update (iconPixmaps suppressed): %s %s, for handler %s"
                          (t -> String
forall a. Show a => a -> String
show t
utype)
                          (ItemInfo -> String
forall a. Show a => a -> String
show (ItemInfo -> String) -> ItemInfo -> String
forall a b. (a -> b) -> a -> b
$ ItemInfo -> ItemInfo
supressPixelData ItemInfo
uinfo)
                          (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Unique -> Int
hashUnique Unique
unique))
        IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ t -> ItemInfo -> IO ()
handler t
utype ItemInfo
uinfo

      doUpdate UpdateType
utype ItemInfo
uinfo =
        MVar [(Unique, UpdateHandler)] -> IO [(Unique, UpdateHandler)]
forall a. MVar a -> IO a
readMVar MVar [(Unique, UpdateHandler)]
updateHandlersVar IO [(Unique, UpdateHandler)]
-> ([(Unique, UpdateHandler)] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Unique, UpdateHandler) -> IO ThreadId)
-> [(Unique, UpdateHandler)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UpdateType -> ItemInfo -> (Unique, UpdateHandler) -> IO ThreadId
forall {t}.
Show t =>
t -> ItemInfo -> (Unique, t -> ItemInfo -> IO ()) -> IO ThreadId
doUpdateForHandler UpdateType
utype ItemInfo
uinfo)

      addHandler UpdateHandler
handler = do
        unique <- IO Unique
newUnique
        modifyMVar_ updateHandlersVar (return . ((unique, handler):))
        let doUpdateForInfo ItemInfo
info = UpdateType -> ItemInfo -> (Unique, UpdateHandler) -> IO ThreadId
forall {t}.
Show t =>
t -> ItemInfo -> (Unique, t -> ItemInfo -> IO ()) -> IO ThreadId
doUpdateForHandler UpdateType
ItemAdded ItemInfo
info (Unique
unique, UpdateHandler
handler)
        readMVar itemInfoMapVar >>= mapM_ doUpdateForInfo
        return unique

      removeHandler Unique
unique =
        MVar [(Unique, UpdateHandler)]
-> ([(Unique, UpdateHandler)] -> IO [(Unique, UpdateHandler)])
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar [(Unique, UpdateHandler)]
updateHandlersVar ([(Unique, UpdateHandler)] -> IO [(Unique, UpdateHandler)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Unique, UpdateHandler)] -> IO [(Unique, UpdateHandler)])
-> ([(Unique, UpdateHandler)] -> [(Unique, UpdateHandler)])
-> [(Unique, UpdateHandler)]
-> IO [(Unique, UpdateHandler)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Unique, UpdateHandler) -> Bool)
-> [(Unique, UpdateHandler)] -> [(Unique, UpdateHandler)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
/= Unique
unique) (Unique -> Bool)
-> ((Unique, UpdateHandler) -> Unique)
-> (Unique, UpdateHandler)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unique, UpdateHandler) -> Unique
forall a b. (a, b) -> a
fst))

      getPixmaps t -> t -> t -> f (f ImageInfo)
getter t
a1 t
a2 t
a3 =
        (ImageInfo -> ImageInfo) -> f ImageInfo -> f ImageInfo
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ImageInfo -> ImageInfo
convertPixmapsToHostByteOrder (f ImageInfo -> f ImageInfo) -> f (f ImageInfo) -> f (f ImageInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> t -> t -> f (f ImageInfo)
getter t
a1 t
a2 t
a3

      getMaybe t -> t -> t -> f (Either d b)
fn t
a t
b t
c = (b -> Maybe b) -> Either d b -> Either d (Maybe b)
forall b c d. (b -> c) -> Either d b -> Either d c
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right b -> Maybe b
forall a. a -> Maybe a
Just (Either d b -> Either d (Maybe b))
-> f (Either d b) -> f (Either d (Maybe b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> t -> t -> f (Either d b)
fn t
a t
b t
c

      parseServiceName String
name =
        let (String
bus, Maybe String
maybePath) = String -> (String, Maybe String)
splitServiceName String
name
        in (String -> BusName
busName_ String
bus, String -> ObjectPath
objectPath_ (String -> ObjectPath) -> Maybe String -> Maybe ObjectPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
maybePath)

      buildItemInfo String
name = ExceptT MethodError IO ItemInfo -> IO (Either MethodError ItemInfo)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT MethodError IO ItemInfo
 -> IO (Either MethodError ItemInfo))
-> ExceptT MethodError IO ItemInfo
-> IO (Either MethodError ItemInfo)
forall a b. (a -> b) -> a -> b
$ do
        let (BusName
busName, Maybe ObjectPath
maybePath) = String -> (BusName, Maybe ObjectPath)
parseServiceName String
name
        path <- case Maybe ObjectPath
maybePath of
          Just ObjectPath
parsedPath -> ObjectPath -> ExceptT MethodError IO ObjectPath
forall a. a -> ExceptT MethodError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ObjectPath
parsedPath
          Maybe ObjectPath
Nothing -> String -> ObjectPath
objectPath_ (String -> ObjectPath)
-> ExceptT MethodError IO String
-> ExceptT MethodError IO ObjectPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either MethodError String) -> ExceptT MethodError IO String
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
            (Client -> String -> IO (Either MethodError String)
W.getObjectPathForItemName Client
client (BusName -> String
forall a b. Coercible a b => a -> b
coerce BusName
busName))
        let doGetDef a
def Client -> BusName -> ObjectPath -> m (Either MethodError a)
fn =
              m (Either MethodError a) -> ExceptT MethodError m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either MethodError a) -> ExceptT MethodError m a)
-> m (Either MethodError a) -> ExceptT MethodError m a
forall a b. (a -> b) -> a -> b
$ a -> Either MethodError a -> Either MethodError a
forall b. b -> Either MethodError b -> Either MethodError b
exemptAll a
def (Either MethodError a -> Either MethodError a)
-> m (Either MethodError a) -> m (Either MethodError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Client -> BusName -> ObjectPath -> m (Either MethodError a)
fn Client
client BusName
busName ObjectPath
path
            doGet Client -> BusName -> ObjectPath -> m (Either e a)
fn = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> ExceptT e m a)
-> m (Either e a) -> ExceptT e m a
forall a b. (a -> b) -> a -> b
$ Client -> BusName -> ObjectPath -> m (Either e a)
fn Client
client BusName
busName ObjectPath
path
        pixmaps <- doGetDef [] $ getPixmaps I.getIconPixmap
        iName <- doGetDef name I.getIconName
        overlayPixmap <- doGetDef [] $ getPixmaps I.getOverlayIconPixmap
        overlayIName <- doGetDef Nothing $ getMaybe I.getOverlayIconName
        themePath <- doGetDef Nothing $ getMaybe I.getIconThemePath
        menu <- doGetDef Nothing $ getMaybe I.getMenu
        title <- doGetDef "" I.getTitle
        tooltip <- doGetDef Nothing $ getMaybe I.getToolTip
        idString <- doGetDef Nothing $ getMaybe I.getId
        status <- doGetDef Nothing $ getMaybe I.getStatus
        category <- doGetDef Nothing $ getMaybe I.getCategory
        itemIsMenu <- doGetDef True I.getItemIsMenu
        return ItemInfo
                 { itemServiceName = busName
                 , itemId = idString
                 , itemStatus = status
                 , itemCategory = category
                 , itemServicePath = path
                 , itemToolTip = tooltip
                 , iconPixmaps = pixmaps
                 , iconThemePath = themePath
                 , iconName = iName
                 , iconTitle = title
                 , menuPath = menu
                 , overlayIconName = overlayIName
                 , overlayIconPixmaps = overlayPixmap
                 , itemIsMenu = itemIsMenu
                 }

      createAll [String]
serviceNames = do
        (errors, itemInfos) <-
          [Either MethodError ItemInfo] -> ([MethodError], [ItemInfo])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either MethodError ItemInfo] -> ([MethodError], [ItemInfo]))
-> IO [Either MethodError ItemInfo]
-> IO ([MethodError], [ItemInfo])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Either MethodError ItemInfo))
-> [String] -> IO [Either MethodError ItemInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO (Either MethodError ItemInfo)
buildItemInfo [String]
serviceNames
        mapM_ (logErrorWithMessage "Error in item building at startup:") errors
        return itemInfos

      registerWithPairs =
        ((Client -> MatchRule -> b -> (Signal -> IO ()) -> IO b, b)
 -> IO b)
-> [(Client -> MatchRule -> b -> (Signal -> IO ()) -> IO b, b)]
-> IO [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (((Client -> MatchRule -> b -> (Signal -> IO ()) -> IO b)
 -> b -> IO b)
-> (Client -> MatchRule -> b -> (Signal -> IO ()) -> IO b, b)
-> IO b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Client -> MatchRule -> b -> (Signal -> IO ()) -> IO b)
-> b -> IO b
forall {a} {t} {t}.
Show a =>
(Client -> MatchRule -> t -> (a -> IO ()) -> t) -> t -> t
clientSignalRegister)
        where logUnableToCallSignal :: a -> IO ()
logUnableToCallSignal a
signal =
                Priority -> String -> IO ()
hostLogger Priority
ERROR (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Unable to call handler with %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                     a -> String
forall a. Show a => a -> String
show a
signal
              clientSignalRegister :: (Client -> MatchRule -> t -> (a -> IO ()) -> t) -> t -> t
clientSignalRegister Client -> MatchRule -> t -> (a -> IO ()) -> t
signalRegisterFn t
handler =
                Client -> MatchRule -> t -> (a -> IO ()) -> t
signalRegisterFn Client
client MatchRule
matchAny t
handler a -> IO ()
forall {a}. Show a => a -> IO ()
logUnableToCallSignal

      -- Resolve a bus name to its unique name owner when it is well-known.
      -- For unique names (":1.42"), the owner is the name itself.
      resolveOwner :: BusName -> IO (Maybe BusName)
      resolveOwner BusName
bus =
        case (BusName -> String
forall a b. Coercible a b => a -> b
coerce BusName
bus :: String) of
          Char
':' : String
_ -> Maybe BusName -> IO (Maybe BusName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
bus)
          String
_ ->
            (MethodError -> Maybe BusName)
-> (String -> Maybe BusName)
-> Either MethodError String
-> Maybe BusName
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe BusName -> MethodError -> Maybe BusName
forall a b. a -> b -> a
const Maybe BusName
forall a. Maybe a
Nothing) (BusName -> Maybe BusName
forall a. a -> Maybe a
Just (BusName -> Maybe BusName)
-> (String -> BusName) -> String -> Maybe BusName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> BusName
busName_) (Either MethodError String -> Maybe BusName)
-> IO (Either MethodError String) -> IO (Maybe BusName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              Client -> String -> IO (Either MethodError String)
DTH.getNameOwner Client
client (BusName -> String
forall a b. Coercible a b => a -> b
coerce BusName
bus)

      handleItemAdded String
serviceName =
        MVar (Map BusName ItemInfo)
-> (Map BusName ItemInfo -> IO (Map BusName ItemInfo)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map BusName ItemInfo)
itemInfoMapVar ((Map BusName ItemInfo -> IO (Map BusName ItemInfo)) -> IO ())
-> (Map BusName ItemInfo -> IO (Map BusName ItemInfo)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Map BusName ItemInfo
itemInfoMap ->
          String -> IO (Either MethodError ItemInfo)
buildItemInfo String
serviceName IO (Either MethodError ItemInfo)
-> (Either MethodError ItemInfo -> IO (Map BusName ItemInfo))
-> IO (Map BusName ItemInfo)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          (MethodError -> IO (Map BusName ItemInfo))
-> (ItemInfo -> IO (Map BusName ItemInfo))
-> Either MethodError ItemInfo
-> IO (Map BusName ItemInfo)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO (Map BusName ItemInfo)
-> MethodError -> IO (Map BusName ItemInfo)
forall {a} {b}. Show a => IO b -> a -> IO b
logErrorAndThen (IO (Map BusName ItemInfo)
 -> MethodError -> IO (Map BusName ItemInfo))
-> IO (Map BusName ItemInfo)
-> MethodError
-> IO (Map BusName ItemInfo)
forall a b. (a -> b) -> a -> b
$ Map BusName ItemInfo -> IO (Map BusName ItemInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Map BusName ItemInfo
itemInfoMap)
                 (Map BusName ItemInfo -> ItemInfo -> IO (Map BusName ItemInfo)
addItemInfo Map BusName ItemInfo
itemInfoMap)
          where addItemInfo :: Map BusName ItemInfo -> ItemInfo -> IO (Map BusName ItemInfo)
addItemInfo Map BusName ItemInfo
map itemInfo :: ItemInfo
itemInfo@ItemInfo{ itemServiceName :: ItemInfo -> BusName
itemServiceName = BusName
newName
                                                 , itemServicePath :: ItemInfo -> ObjectPath
itemServicePath = ObjectPath
newPath
                                                 } =
                  if BusName -> Map BusName ItemInfo -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member BusName
newName Map BusName ItemInfo
map
                  then Map BusName ItemInfo -> IO (Map BusName ItemInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Map BusName ItemInfo
map
                  else do
                    -- When the watcher restarts, some items may re-register
                    -- under a different bus name (e.g. switching between
                    -- unique name and a well-known name). Detect that by
                    -- matching on the item's unique name owner, and replace
                    -- the existing entry rather than creating a duplicate.
                    newOwner <- BusName -> IO (Maybe BusName)
resolveOwner BusName
newName
                    let matchesOwnerAndPath (BusName
existingName, ItemInfo
existingInfo) = do
                          existingOwner <- BusName -> IO (Maybe BusName)
resolveOwner BusName
existingName
                          pure $
                            existingName /= newName
                              && existingOwner == newOwner
                              && itemServicePath existingInfo == newPath
                        addFresh = do
                          UpdateHandler
doUpdate UpdateType
ItemAdded ItemInfo
itemInfo
                          Map BusName ItemInfo -> IO (Map BusName ItemInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BusName -> ItemInfo -> Map BusName ItemInfo -> Map BusName ItemInfo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BusName
newName ItemInfo
itemInfo Map BusName ItemInfo
map)
                    case newOwner of
                      Maybe BusName
Nothing -> IO (Map BusName ItemInfo)
addFresh
                      Just BusName
_ -> do
                        existing <- ((BusName, ItemInfo) -> IO Bool)
-> [(BusName, ItemInfo)] -> IO (Maybe (BusName, ItemInfo))
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM (BusName, ItemInfo) -> IO Bool
matchesOwnerAndPath (Map BusName ItemInfo -> [(BusName, ItemInfo)]
forall k a. Map k a -> [(k, a)]
Map.toList Map BusName ItemInfo
map)
                        case existing of
                          Maybe (BusName, ItemInfo)
Nothing -> IO (Map BusName ItemInfo)
addFresh
                          Just (BusName
existingName, ItemInfo
existingInfo) -> do
                            UpdateHandler
doUpdate UpdateType
ItemRemoved ItemInfo
existingInfo
                            UpdateHandler
doUpdate UpdateType
ItemAdded ItemInfo
itemInfo
                            Map BusName ItemInfo -> IO (Map BusName ItemInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map BusName ItemInfo -> IO (Map BusName ItemInfo))
-> Map BusName ItemInfo -> IO (Map BusName ItemInfo)
forall a b. (a -> b) -> a -> b
$
                              BusName -> ItemInfo -> Map BusName ItemInfo -> Map BusName ItemInfo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BusName
newName ItemInfo
itemInfo (Map BusName ItemInfo -> Map BusName ItemInfo)
-> Map BusName ItemInfo -> Map BusName ItemInfo
forall a b. (a -> b) -> a -> b
$
                                BusName -> Map BusName ItemInfo -> Map BusName ItemInfo
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete BusName
existingName Map BusName ItemInfo
map

      getObjectPathForItemName BusName
name =
        ObjectPath
-> (ItemInfo -> ObjectPath) -> Maybe ItemInfo -> ObjectPath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ObjectPath
I.defaultPath ItemInfo -> ObjectPath
itemServicePath (Maybe ItemInfo -> ObjectPath)
-> (Map BusName ItemInfo -> Maybe ItemInfo)
-> Map BusName ItemInfo
-> ObjectPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BusName -> Map BusName ItemInfo -> Maybe ItemInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BusName
name (Map BusName ItemInfo -> ObjectPath)
-> IO (Map BusName ItemInfo) -> IO ObjectPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        MVar (Map BusName ItemInfo) -> IO (Map BusName ItemInfo)
forall a. MVar a -> IO a
readMVar MVar (Map BusName ItemInfo)
itemInfoMapVar

      handleItemRemoved String
serviceName =
        MVar (Map BusName ItemInfo)
-> (Map BusName ItemInfo
    -> IO (Map BusName ItemInfo, Maybe ItemInfo))
-> IO (Maybe ItemInfo)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Map BusName ItemInfo)
itemInfoMapVar Map BusName ItemInfo -> IO (Map BusName ItemInfo, Maybe ItemInfo)
forall {m :: * -> *} {a}.
Monad m =>
Map BusName a -> m (Map BusName a, Maybe a)
doRemove IO (Maybe ItemInfo) -> (Maybe ItemInfo -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        IO () -> (ItemInfo -> IO ()) -> Maybe ItemInfo -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ()
logNonExistentRemoval (UpdateHandler
doUpdate UpdateType
ItemRemoved)
        where
          busName :: BusName
busName = (BusName, Maybe ObjectPath) -> BusName
forall a b. (a, b) -> a
fst (String -> (BusName, Maybe ObjectPath)
parseServiceName String
serviceName)
          doRemove :: Map BusName a -> m (Map BusName a, Maybe a)
doRemove Map BusName a
currentMap =
            (Map BusName a, Maybe a) -> m (Map BusName a, Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BusName -> Map BusName a -> Map BusName a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete BusName
busName Map BusName a
currentMap, BusName -> Map BusName a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BusName
busName Map BusName a
currentMap)
          logNonExistentRemoval :: IO ()
logNonExistentRemoval =
            -- This can happen due to watcher/host races (e.g. watcher restart).
            Priority -> String -> IO ()
hostLogger Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Attempt to remove unknown item %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                       BusName -> String
forall a. Show a => a -> String
show BusName
busName

      watcherRegistrationPairs =
        [ (Client
-> MatchRule
-> (Signal -> String -> IO ())
-> (Signal -> IO ())
-> IO SignalHandler
W.registerForStatusNotifierItemRegistered, (String -> IO ()) -> b -> String -> IO ()
forall a b. a -> b -> a
const String -> IO ()
handleItemAdded)
        , (Client
-> MatchRule
-> (Signal -> String -> IO ())
-> (Signal -> IO ())
-> IO SignalHandler
W.registerForStatusNotifierItemUnregistered, (String -> IO ()) -> b -> String -> IO ()
forall a b. a -> b -> a
const String -> IO ()
handleItemRemoved)
        ]

      watcherServiceName = InterfaceName -> String
forall a b. Coercible a b => a -> b
coerce (InterfaceName -> String) -> InterfaceName -> String
forall a b. (a -> b) -> a -> b
$ String -> InterfaceName
W.getWatcherInterfaceName String
namespaceString

      synchronizeItemsWithWatcher = do
        let retryDelayMicros :: Int
retryDelayMicros = Int
50000
            maxRetries :: Integer
maxRetries = Integer
20
            fetchWatcherItems :: t -> IO (Either MethodError [String])
fetchWatcherItems t
retries = do
              watcherItemsResult <- Client -> IO (Either MethodError [String])
W.getRegisteredStatusNotifierItems Client
client
              case watcherItemsResult of
                Right [String]
watcherItems -> Either MethodError [String] -> IO (Either MethodError [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either MethodError [String] -> IO (Either MethodError [String]))
-> Either MethodError [String] -> IO (Either MethodError [String])
forall a b. (a -> b) -> a -> b
$ [String] -> Either MethodError [String]
forall a b. b -> Either a b
Right [String]
watcherItems
                Left MethodError
err ->
                  if t
retries t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0
                    then Either MethodError [String] -> IO (Either MethodError [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either MethodError [String] -> IO (Either MethodError [String]))
-> Either MethodError [String] -> IO (Either MethodError [String])
forall a b. (a -> b) -> a -> b
$ MethodError -> Either MethodError [String]
forall a b. a -> Either a b
Left MethodError
err
                    else Int -> IO ()
threadDelay Int
retryDelayMicros IO ()
-> IO (Either MethodError [String])
-> IO (Either MethodError [String])
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                         t -> IO (Either MethodError [String])
fetchWatcherItems (t
retries t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
        watcherItemsResult <- Integer -> IO (Either MethodError [String])
forall {t}. (Ord t, Num t) => t -> IO (Either MethodError [String])
fetchWatcherItems Integer
maxRetries
        case watcherItemsResult of
          Left MethodError
err ->
            String -> MethodError -> IO ()
forall {a}. Show a => String -> a -> IO ()
logErrorWithMessage String
"Failed to synchronize host state with watcher:" MethodError
err
          Right [String]
watcherServiceNames -> do
            currentMap <- MVar (Map BusName ItemInfo) -> IO (Map BusName ItemInfo)
forall a. MVar a -> IO a
readMVar MVar (Map BusName ItemInfo)
itemInfoMapVar
            let watcherBusNames = (String -> BusName) -> [String] -> [BusName]
forall a b. (a -> b) -> [a] -> [b]
map ((BusName, Maybe ObjectPath) -> BusName
forall a b. (a, b) -> a
fst ((BusName, Maybe ObjectPath) -> BusName)
-> (String -> (BusName, Maybe ObjectPath)) -> String -> BusName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (BusName, Maybe ObjectPath)
parseServiceName) [String]
watcherServiceNames
                missingFromWatcher =
                  (BusName -> Bool) -> [BusName] -> [BusName]
forall a. (a -> Bool) -> [a] -> [a]
filter (BusName -> [BusName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [BusName]
watcherBusNames) (Map BusName ItemInfo -> [BusName]
forall k a. Map k a -> [k]
Map.keys Map BusName ItemInfo
currentMap)
            mapM_ (handleItemRemoved . coerce) missingFromWatcher
            mapM_ handleItemAdded watcherServiceNames

      handleWatcherNameOwnerChanged p
_ String
name p
_ a
newOwner =
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
watcherServiceName Bool -> Bool -> Bool
&& a
newOwner a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          String -> IO ()
logInfo String
"Watcher owner changed; synchronizing item state."
          IO ()
synchronizeItemsWithWatcher

      getSender BusName -> IO ()
fn s :: Signal
s@M.Signal { signalSender :: Signal -> Maybe BusName
M.signalSender = Just BusName
sender} =
        -- Signal dumps are too noisy at INFO.
        String -> IO ()
logDebug (Signal -> String
forall a. Show a => a -> String
show Signal
s) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BusName -> IO ()
fn BusName
sender
      getSender BusName -> IO ()
_ Signal
s = String -> IO ()
logError (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Received signal with no sender: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Signal -> String
forall a. Show a => a -> String
show Signal
s

      runProperty Client -> BusName -> ObjectPath -> IO b
prop BusName
serviceName =
        BusName -> IO ObjectPath
getObjectPathForItemName BusName
serviceName IO ObjectPath -> (ObjectPath -> IO b) -> IO b
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Client -> BusName -> ObjectPath -> IO b
prop Client
client BusName
serviceName

      logUnknownSender a
updateType a
signal =
        Priority -> String -> IO ()
hostLogger Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                   String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Got signal for update type: %s from unknown sender: %s"
                   (a -> String
forall a. Show a => a -> String
show a
updateType) (a -> String
forall a. Show a => a -> String
show a
signal)

      identifySender M.Signal { signalSender :: Signal -> Maybe BusName
M.signalSender = Just BusName
sender
                              , signalPath :: Signal -> ObjectPath
M.signalPath = ObjectPath
senderPath
                              } = do
        infoMap <- MVar (Map BusName ItemInfo) -> IO (Map BusName ItemInfo)
forall a. MVar a -> IO a
readMVar MVar (Map BusName ItemInfo)
itemInfoMapVar
        let identifySenderBySender = Maybe ItemInfo -> IO (Maybe ItemInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BusName -> Map BusName ItemInfo -> Maybe ItemInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BusName
sender Map BusName ItemInfo
infoMap)
            identifySenderByNameOwner =
              let matchByOwner :: ItemInfo -> IO Bool
matchByOwner ItemInfo
info = do
                    ownerResult <- Client -> String -> IO (Either MethodError String)
DTH.getNameOwner Client
client
                                   (BusName -> String
forall a b. Coercible a b => a -> b
coerce (BusName -> String) -> BusName -> String
forall a b. (a -> b) -> a -> b
$ ItemInfo -> BusName
itemServiceName ItemInfo
info)
                    return $ case ownerResult of
                      Right String
owner -> String
owner String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== BusName -> String
forall a b. Coercible a b => a -> b
coerce BusName
sender
                      Left MethodError
_ -> Bool
False
              in (ItemInfo -> IO Bool) -> [ItemInfo] -> IO (Maybe ItemInfo)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM ItemInfo -> IO Bool
matchByOwner (Map BusName ItemInfo -> [ItemInfo]
forall k a. Map k a -> [a]
Map.elems Map BusName ItemInfo
infoMap)
            identifySenderById = (Maybe (Maybe ItemInfo) -> Maybe ItemInfo)
-> IO (Maybe (Maybe ItemInfo)) -> IO (Maybe ItemInfo)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe ItemInfo) -> Maybe ItemInfo
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (Maybe (Maybe ItemInfo)) -> IO (Maybe ItemInfo))
-> IO (Maybe (Maybe ItemInfo)) -> IO (Maybe ItemInfo)
forall a b. (a -> b) -> a -> b
$
              IO (Either MethodError (Maybe ItemInfo))
identifySenderById_ IO (Either MethodError (Maybe ItemInfo))
-> (Either MethodError (Maybe ItemInfo)
    -> IO (Maybe (Maybe ItemInfo)))
-> IO (Maybe (Maybe ItemInfo))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either MethodError (Maybe ItemInfo) -> IO (Maybe (Maybe ItemInfo))
forall {a}. Either MethodError a -> IO (Maybe a)
logIdentifyByIdResult
            logIdentifyByIdResult
              (Left M.MethodError { methodErrorName :: MethodError -> ErrorName
M.methodErrorName = ErrorName
errName })
              | ErrorName
errName ErrorName -> ErrorName -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorName
errorUnknownMethod =
                  Priority -> String -> IO ()
hostLogger Priority
DEBUG
                    (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Item does not support getId: %s"
                      (ErrorName -> String
forall a. Show a => a -> String
show ErrorName
errName)) IO () -> IO (Maybe a) -> IO (Maybe a)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                  Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
            logIdentifyByIdResult Either MethodError a
result =
              (Priority -> String -> IO ())
-> String -> Either MethodError a -> IO (Maybe a)
forall a b.
Show a =>
(Priority -> String -> IO ())
-> String -> Either a b -> IO (Maybe b)
logEitherError Priority -> String -> IO ()
hostLogger String
"Failed to identify sender" Either MethodError a
result
            identifySenderById_ = ExceptT MethodError IO (Maybe ItemInfo)
-> IO (Either MethodError (Maybe ItemInfo))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT MethodError IO (Maybe ItemInfo)
 -> IO (Either MethodError (Maybe ItemInfo)))
-> ExceptT MethodError IO (Maybe ItemInfo)
-> IO (Either MethodError (Maybe ItemInfo))
forall a b. (a -> b) -> a -> b
$ do
              senderId <- IO (Either MethodError String) -> ExceptT MethodError IO String
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either MethodError String) -> ExceptT MethodError IO String)
-> IO (Either MethodError String) -> ExceptT MethodError IO String
forall a b. (a -> b) -> a -> b
$ Client -> BusName -> ObjectPath -> IO (Either MethodError String)
I.getId Client
client BusName
sender ObjectPath
senderPath
              let matchesSender ItemInfo
info =
                    if ItemInfo -> Maybe String
itemId ItemInfo
info Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
senderId
                    then do
                      senderNameOwner <- Client -> String -> IO (Either MethodError String)
DTH.getNameOwner Client
client (BusName -> String
forall a b. Coercible a b => a -> b
coerce BusName
sender)
                      infoNameOwner <- DTH.getNameOwner client (coerce $ itemServiceName info)
                      let warningMsg =
                            String
"Matched sender id: %s, but name owners do not \
                            \ match: %s %s. Considered match: %s."
                          warningText = String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
warningMsg
                                        (String -> String
forall a. Show a => a -> String
show String
senderId)
                                        (Either MethodError String -> String
forall a. Show a => a -> String
show Either MethodError String
senderNameOwner)
                                        (Either MethodError String -> String
forall a. Show a => a -> String
show Either MethodError String
infoNameOwner)
                      when (senderNameOwner /= infoNameOwner) $
                           hostLogger DEBUG warningText
                      return doMatchUnmatchedSender
                    else Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
              lift $ findM matchesSender (Map.elems infoMap)
        identifySenderBySender <||> identifySenderByNameOwner <||> identifySenderById
        where m (Maybe a)
a <||> :: m (Maybe a) -> m (Maybe a) -> m (Maybe a)
<||> m (Maybe a)
b = MaybeT m a -> m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m a -> m (Maybe a)) -> MaybeT m a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT m (Maybe a)
a MaybeT m a -> MaybeT m a -> MaybeT m a
forall a. MaybeT m a -> MaybeT m a -> MaybeT m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT m (Maybe a)
b
      identifySender Signal
_ = Maybe ItemInfo -> IO (Maybe ItemInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ItemInfo
forall a. Maybe a
Nothing

      updateItemByLensAndProp (a -> Identity a) -> ItemInfo -> Identity ItemInfo
lens Client -> BusName -> ObjectPath -> IO (Either MethodError a)
prop BusName
busName = ExceptT MethodError IO ItemInfo -> IO (Either MethodError ItemInfo)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT MethodError IO ItemInfo
 -> IO (Either MethodError ItemInfo))
-> ExceptT MethodError IO ItemInfo
-> IO (Either MethodError ItemInfo)
forall a b. (a -> b) -> a -> b
$ do
        newValue <- IO (Either MethodError a) -> ExceptT MethodError IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ((Client -> BusName -> ObjectPath -> IO (Either MethodError a))
-> BusName -> IO (Either MethodError a)
forall {b}.
(Client -> BusName -> ObjectPath -> IO b) -> BusName -> IO b
runProperty Client -> BusName -> ObjectPath -> IO (Either MethodError a)
prop BusName
busName)
        let modify Map BusName ItemInfo
infoMap =
              -- This noops when the value is not present
              let newMap :: Map BusName ItemInfo
newMap = ASetter (Map BusName ItemInfo) (Map BusName ItemInfo) a a
-> a -> Map BusName ItemInfo -> Map BusName ItemInfo
forall s t a b. ASetter s t a b -> b -> s -> t
set (Index (Map BusName ItemInfo)
-> Lens'
     (Map BusName ItemInfo) (Maybe (IxValue (Map BusName ItemInfo)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at BusName
Index (Map BusName ItemInfo)
busName ((Maybe (IxValue (Map BusName ItemInfo))
  -> Identity (Maybe (IxValue (Map BusName ItemInfo))))
 -> Map BusName ItemInfo -> Identity (Map BusName ItemInfo))
-> ((a -> Identity a)
    -> Maybe (IxValue (Map BusName ItemInfo))
    -> Identity (Maybe (IxValue (Map BusName ItemInfo))))
-> ASetter (Map BusName ItemInfo) (Map BusName ItemInfo) a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IxValue (Map BusName ItemInfo)
 -> Identity (IxValue (Map BusName ItemInfo)))
-> Maybe (IxValue (Map BusName ItemInfo))
-> Identity (Maybe (IxValue (Map BusName ItemInfo)))
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((IxValue (Map BusName ItemInfo)
  -> Identity (IxValue (Map BusName ItemInfo)))
 -> Maybe (IxValue (Map BusName ItemInfo))
 -> Identity (Maybe (IxValue (Map BusName ItemInfo))))
-> ((a -> Identity a)
    -> IxValue (Map BusName ItemInfo)
    -> Identity (IxValue (Map BusName ItemInfo)))
-> (a -> Identity a)
-> Maybe (IxValue (Map BusName ItemInfo))
-> Identity (Maybe (IxValue (Map BusName ItemInfo)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity a)
-> IxValue (Map BusName ItemInfo)
-> Identity (IxValue (Map BusName ItemInfo))
(a -> Identity a) -> ItemInfo -> Identity ItemInfo
lens) a
newValue Map BusName ItemInfo
infoMap
              in (Map BusName ItemInfo, Maybe ItemInfo)
-> m (Map BusName ItemInfo, Maybe ItemInfo)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map BusName ItemInfo
newMap, BusName -> Map BusName ItemInfo -> Maybe ItemInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BusName
busName Map BusName ItemInfo
newMap)
        ExceptT $ maybeToEither (methodError (Serial 0) errorFailed) <$>
                modifyMVar itemInfoMapVar modify

      logErrorsHandler (a -> Identity a) -> ItemInfo -> Identity ItemInfo
lens UpdateType
updateType Client -> BusName -> ObjectPath -> IO (Either MethodError a)
prop =
        [BusName -> IO (Either MethodError ItemInfo)]
-> UpdateType -> Signal -> IO ()
runUpdaters [((a -> Identity a) -> ItemInfo -> Identity ItemInfo)
-> (Client -> BusName -> ObjectPath -> IO (Either MethodError a))
-> BusName
-> IO (Either MethodError ItemInfo)
forall {a} {a}.
((a -> Identity a) -> ItemInfo -> Identity ItemInfo)
-> (Client -> BusName -> ObjectPath -> IO (Either MethodError a))
-> BusName
-> IO (Either MethodError ItemInfo)
updateItemByLensAndProp (a -> Identity a) -> ItemInfo -> Identity ItemInfo
lens Client -> BusName -> ObjectPath -> IO (Either MethodError a)
prop] UpdateType
updateType

      -- Run all the provided updaters with the expectation that at least one
      -- will succeed.
      runUpdatersForService [p -> IO (Either MethodError ItemInfo)]
updaters UpdateType
updateType p
serviceName = do
        updateResults <- ((p -> IO (Either MethodError ItemInfo))
 -> IO (Either MethodError ItemInfo))
-> [p -> IO (Either MethodError ItemInfo)]
-> IO [Either MethodError ItemInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((p -> IO (Either MethodError ItemInfo))
-> p -> IO (Either MethodError ItemInfo)
forall a b. (a -> b) -> a -> b
$ p
serviceName) [p -> IO (Either MethodError ItemInfo)]
updaters
        let (failures, updates) = partitionEithers updateResults
            logLevel = [MethodError] -> [ItemInfo] -> Priority
forall a. [MethodError] -> [a] -> Priority
propertyUpdateFailureLogLevel [MethodError]
failures [ItemInfo]
updates
        mapM_ (doUpdate updateType) updates
        when (not $ null failures) $
             hostLogger logLevel $ printf "Property update failures %s" $
                        show failures

      runUpdaters [BusName -> IO (Either MethodError ItemInfo)]
updaters UpdateType
updateType Signal
signal =
        Signal -> IO (Maybe ItemInfo)
identifySender Signal
signal IO (Maybe ItemInfo) -> (Maybe ItemInfo -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (ItemInfo -> IO ()) -> Maybe ItemInfo -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ()
runForAll (BusName -> IO ()
runUpdateForService (BusName -> IO ()) -> (ItemInfo -> BusName) -> ItemInfo -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ItemInfo -> BusName
itemServiceName)
        where runUpdateForService :: BusName -> IO ()
runUpdateForService = [BusName -> IO (Either MethodError ItemInfo)]
-> UpdateType -> BusName -> IO ()
forall {p}.
[p -> IO (Either MethodError ItemInfo)] -> UpdateType -> p -> IO ()
runUpdatersForService [BusName -> IO (Either MethodError ItemInfo)]
updaters UpdateType
updateType
              runForAll :: IO ()
runForAll = UpdateType -> Signal -> IO ()
forall {a} {a}. (Show a, Show a) => a -> a -> IO ()
logUnknownSender UpdateType
updateType Signal
signal IO () -> IO (Map BusName ItemInfo) -> IO (Map BusName ItemInfo)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                          MVar (Map BusName ItemInfo) -> IO (Map BusName ItemInfo)
forall a. MVar a -> IO a
readMVar MVar (Map BusName ItemInfo)
itemInfoMapVar IO (Map BusName ItemInfo)
-> (Map BusName ItemInfo -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                          (BusName -> IO ()) -> [BusName] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BusName -> IO ()
runUpdateForService ([BusName] -> IO ())
-> (Map BusName ItemInfo -> [BusName])
-> Map BusName ItemInfo
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map BusName ItemInfo -> [BusName]
forall k a. Map k a -> [k]
Map.keys

      updateIconPixmaps =
        ((ImageInfo -> Identity ImageInfo)
 -> ItemInfo -> Identity ItemInfo)
-> (Client
    -> BusName -> ObjectPath -> IO (Either MethodError ImageInfo))
-> BusName
-> IO (Either MethodError ItemInfo)
forall {a} {a}.
((a -> Identity a) -> ItemInfo -> Identity ItemInfo)
-> (Client -> BusName -> ObjectPath -> IO (Either MethodError a))
-> BusName
-> IO (Either MethodError ItemInfo)
updateItemByLensAndProp (ImageInfo -> Identity ImageInfo) -> ItemInfo -> Identity ItemInfo
Lens' ItemInfo ImageInfo
iconPixmapsL ((Client
  -> BusName -> ObjectPath -> IO (Either MethodError ImageInfo))
 -> BusName -> IO (Either MethodError ItemInfo))
-> (Client
    -> BusName -> ObjectPath -> IO (Either MethodError ImageInfo))
-> BusName
-> IO (Either MethodError ItemInfo)
forall a b. (a -> b) -> a -> b
$ (Client
 -> BusName -> ObjectPath -> IO (Either MethodError ImageInfo))
-> Client
-> BusName
-> ObjectPath
-> IO (Either MethodError ImageInfo)
forall {f :: * -> *} {f :: * -> *} {t} {t} {t}.
(Functor f, Functor f) =>
(t -> t -> t -> f (f ImageInfo)) -> t -> t -> t -> f (f ImageInfo)
getPixmaps Client
-> BusName -> ObjectPath -> IO (Either MethodError ImageInfo)
I.getIconPixmap

      updateIconName =
        ((String -> Identity String) -> ItemInfo -> Identity ItemInfo)
-> (Client
    -> BusName -> ObjectPath -> IO (Either MethodError String))
-> BusName
-> IO (Either MethodError ItemInfo)
forall {a} {a}.
((a -> Identity a) -> ItemInfo -> Identity ItemInfo)
-> (Client -> BusName -> ObjectPath -> IO (Either MethodError a))
-> BusName
-> IO (Either MethodError ItemInfo)
updateItemByLensAndProp (String -> Identity String) -> ItemInfo -> Identity ItemInfo
Lens' ItemInfo String
iconNameL Client -> BusName -> ObjectPath -> IO (Either MethodError String)
I.getIconName

      updateIconTheme =
        ((Maybe String -> Identity (Maybe String))
 -> ItemInfo -> Identity ItemInfo)
-> (Client
    -> BusName -> ObjectPath -> IO (Either MethodError (Maybe String)))
-> BusName
-> IO (Either MethodError ItemInfo)
forall {a} {a}.
((a -> Identity a) -> ItemInfo -> Identity ItemInfo)
-> (Client -> BusName -> ObjectPath -> IO (Either MethodError a))
-> BusName
-> IO (Either MethodError ItemInfo)
updateItemByLensAndProp (Maybe String -> Identity (Maybe String))
-> ItemInfo -> Identity ItemInfo
Lens' ItemInfo (Maybe String)
iconThemePathL Client
-> BusName -> ObjectPath -> IO (Either MethodError (Maybe String))
getThemePathDefault

      updateFromIconThemeFromSignal Signal
signal =
        Signal -> IO (Maybe ItemInfo)
identifySender Signal
signal IO (Maybe ItemInfo)
-> (Maybe ItemInfo -> IO (Maybe (Either MethodError ItemInfo)))
-> IO (Maybe (Either MethodError ItemInfo))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ItemInfo -> IO (Either MethodError ItemInfo))
-> Maybe ItemInfo -> IO (Maybe (Either MethodError ItemInfo))
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) -> Maybe a -> f (Maybe b)
traverse (BusName -> IO (Either MethodError ItemInfo)
updateIconTheme (BusName -> IO (Either MethodError ItemInfo))
-> (ItemInfo -> BusName)
-> ItemInfo
-> IO (Either MethodError ItemInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ItemInfo -> BusName
itemServiceName)

      handleNewIcon Signal
signal = do
        -- XXX: This avoids the case where the theme path is updated before the
        -- icon name is updated when both signals are sent simultaneously
        Signal -> IO (Maybe (Either MethodError ItemInfo))
updateFromIconThemeFromSignal Signal
signal
        [BusName -> IO (Either MethodError ItemInfo)]
-> UpdateType -> Signal -> IO ()
runUpdaters [BusName -> IO (Either MethodError ItemInfo)
updateIconPixmaps, BusName -> IO (Either MethodError ItemInfo)
updateIconName]
                    UpdateType
IconUpdated Signal
signal

      updateOverlayIconName =
        ((Maybe String -> Identity (Maybe String))
 -> ItemInfo -> Identity ItemInfo)
-> (Client
    -> BusName -> ObjectPath -> IO (Either MethodError (Maybe String)))
-> BusName
-> IO (Either MethodError ItemInfo)
forall {a} {a}.
((a -> Identity a) -> ItemInfo -> Identity ItemInfo)
-> (Client -> BusName -> ObjectPath -> IO (Either MethodError a))
-> BusName
-> IO (Either MethodError ItemInfo)
updateItemByLensAndProp (Maybe String -> Identity (Maybe String))
-> ItemInfo -> Identity ItemInfo
Lens' ItemInfo (Maybe String)
overlayIconNameL ((Client
  -> BusName -> ObjectPath -> IO (Either MethodError (Maybe String)))
 -> BusName -> IO (Either MethodError ItemInfo))
-> (Client
    -> BusName -> ObjectPath -> IO (Either MethodError (Maybe String)))
-> BusName
-> IO (Either MethodError ItemInfo)
forall a b. (a -> b) -> a -> b
$
                                (Client -> BusName -> ObjectPath -> IO (Either MethodError String))
-> Client
-> BusName
-> ObjectPath
-> IO (Either MethodError (Maybe String))
forall {f :: * -> *} {t} {t} {t} {d} {b}.
Functor f =>
(t -> t -> t -> f (Either d b))
-> t -> t -> t -> f (Either d (Maybe b))
getMaybe Client -> BusName -> ObjectPath -> IO (Either MethodError String)
I.getOverlayIconName

      updateOverlayIconPixmaps =
        ((ImageInfo -> Identity ImageInfo)
 -> ItemInfo -> Identity ItemInfo)
-> (Client
    -> BusName -> ObjectPath -> IO (Either MethodError ImageInfo))
-> BusName
-> IO (Either MethodError ItemInfo)
forall {a} {a}.
((a -> Identity a) -> ItemInfo -> Identity ItemInfo)
-> (Client -> BusName -> ObjectPath -> IO (Either MethodError a))
-> BusName
-> IO (Either MethodError ItemInfo)
updateItemByLensAndProp (ImageInfo -> Identity ImageInfo) -> ItemInfo -> Identity ItemInfo
Lens' ItemInfo ImageInfo
overlayIconPixmapsL ((Client
  -> BusName -> ObjectPath -> IO (Either MethodError ImageInfo))
 -> BusName -> IO (Either MethodError ItemInfo))
-> (Client
    -> BusName -> ObjectPath -> IO (Either MethodError ImageInfo))
-> BusName
-> IO (Either MethodError ItemInfo)
forall a b. (a -> b) -> a -> b
$
                                (Client
 -> BusName -> ObjectPath -> IO (Either MethodError ImageInfo))
-> Client
-> BusName
-> ObjectPath
-> IO (Either MethodError ImageInfo)
forall {f :: * -> *} {f :: * -> *} {t} {t} {t}.
(Functor f, Functor f) =>
(t -> t -> t -> f (f ImageInfo)) -> t -> t -> t -> f (f ImageInfo)
getPixmaps Client
-> BusName -> ObjectPath -> IO (Either MethodError ImageInfo)
I.getOverlayIconPixmap

      handleNewOverlayIcon Signal
signal = do
        Signal -> IO (Maybe (Either MethodError ItemInfo))
updateFromIconThemeFromSignal Signal
signal
        [BusName -> IO (Either MethodError ItemInfo)]
-> UpdateType -> Signal -> IO ()
runUpdaters [BusName -> IO (Either MethodError ItemInfo)
updateOverlayIconPixmaps, BusName -> IO (Either MethodError ItemInfo)
updateOverlayIconName]
                    UpdateType
OverlayIconUpdated Signal
signal

      getThemePathDefault Client
client BusName
busName ObjectPath
objectPath =
        (String -> Maybe String)
-> Either MethodError String -> Either MethodError (Maybe String)
forall b c d. (b -> c) -> Either d b -> Either d c
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right String -> Maybe String
forall a. a -> Maybe a
Just (Either MethodError String -> Either MethodError (Maybe String))
-> IO (Either MethodError String)
-> IO (Either MethodError (Maybe String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Client -> BusName -> ObjectPath -> IO (Either MethodError String)
I.getIconThemePath Client
client BusName
busName ObjectPath
objectPath

      handleNewTitle =
        ((String -> Identity String) -> ItemInfo -> Identity ItemInfo)
-> UpdateType
-> (Client
    -> BusName -> ObjectPath -> IO (Either MethodError String))
-> Signal
-> IO ()
forall {a} {a}.
((a -> Identity a) -> ItemInfo -> Identity ItemInfo)
-> UpdateType
-> (Client -> BusName -> ObjectPath -> IO (Either MethodError a))
-> Signal
-> IO ()
logErrorsHandler (String -> Identity String) -> ItemInfo -> Identity ItemInfo
Lens' ItemInfo String
iconTitleL UpdateType
TitleUpdated Client -> BusName -> ObjectPath -> IO (Either MethodError String)
I.getTitle

      handleNewTooltip =
        ((Maybe (String, ImageInfo, String, String)
  -> Identity (Maybe (String, ImageInfo, String, String)))
 -> ItemInfo -> Identity ItemInfo)
-> UpdateType
-> (Client
    -> BusName
    -> ObjectPath
    -> IO
         (Either MethodError (Maybe (String, ImageInfo, String, String))))
-> Signal
-> IO ()
forall {a} {a}.
((a -> Identity a) -> ItemInfo -> Identity ItemInfo)
-> UpdateType
-> (Client -> BusName -> ObjectPath -> IO (Either MethodError a))
-> Signal
-> IO ()
logErrorsHandler (Maybe (String, ImageInfo, String, String)
 -> Identity (Maybe (String, ImageInfo, String, String)))
-> ItemInfo -> Identity ItemInfo
Lens' ItemInfo (Maybe (String, ImageInfo, String, String))
itemToolTipL UpdateType
ToolTipUpdated ((Client
  -> BusName
  -> ObjectPath
  -> IO
       (Either MethodError (Maybe (String, ImageInfo, String, String))))
 -> Signal -> IO ())
-> (Client
    -> BusName
    -> ObjectPath
    -> IO
         (Either MethodError (Maybe (String, ImageInfo, String, String))))
-> Signal
-> IO ()
forall a b. (a -> b) -> a -> b
$ (Client
 -> BusName
 -> ObjectPath
 -> IO (Either MethodError (String, ImageInfo, String, String)))
-> Client
-> BusName
-> ObjectPath
-> IO
     (Either MethodError (Maybe (String, ImageInfo, String, String)))
forall {f :: * -> *} {t} {t} {t} {d} {b}.
Functor f =>
(t -> t -> t -> f (Either d b))
-> t -> t -> t -> f (Either d (Maybe b))
getMaybe Client
-> BusName
-> ObjectPath
-> IO (Either MethodError (String, ImageInfo, String, String))
I.getToolTip

      handleNewStatus =
        ((Maybe String -> Identity (Maybe String))
 -> ItemInfo -> Identity ItemInfo)
-> UpdateType
-> (Client
    -> BusName -> ObjectPath -> IO (Either MethodError (Maybe String)))
-> Signal
-> IO ()
forall {a} {a}.
((a -> Identity a) -> ItemInfo -> Identity ItemInfo)
-> UpdateType
-> (Client -> BusName -> ObjectPath -> IO (Either MethodError a))
-> Signal
-> IO ()
logErrorsHandler (Maybe String -> Identity (Maybe String))
-> ItemInfo -> Identity ItemInfo
Lens' ItemInfo (Maybe String)
itemStatusL UpdateType
StatusUpdated ((Client
  -> BusName -> ObjectPath -> IO (Either MethodError (Maybe String)))
 -> Signal -> IO ())
-> (Client
    -> BusName -> ObjectPath -> IO (Either MethodError (Maybe String)))
-> Signal
-> IO ()
forall a b. (a -> b) -> a -> b
$ (Client -> BusName -> ObjectPath -> IO (Either MethodError String))
-> Client
-> BusName
-> ObjectPath
-> IO (Either MethodError (Maybe String))
forall {f :: * -> *} {t} {t} {t} {d} {b}.
Functor f =>
(t -> t -> t -> f (Either d b))
-> t -> t -> t -> f (Either d (Maybe b))
getMaybe Client -> BusName -> ObjectPath -> IO (Either MethodError String)
I.getStatus

      clientRegistrationPairs =
        [ (Client
-> MatchRule
-> (Signal -> IO ())
-> (Signal -> IO ())
-> IO SignalHandler
I.registerForNewIcon, Signal -> IO ()
handleNewIcon)
        , (Client
-> MatchRule
-> (Signal -> IO ())
-> (Signal -> IO ())
-> IO SignalHandler
I.registerForNewIconThemePath, Signal -> IO ()
handleNewIcon)
        , (Client
-> MatchRule
-> (Signal -> IO ())
-> (Signal -> IO ())
-> IO SignalHandler
I.registerForNewOverlayIcon, Signal -> IO ()
handleNewOverlayIcon)
        , (Client
-> MatchRule
-> (Signal -> IO ())
-> (Signal -> IO ())
-> IO SignalHandler
I.registerForNewTitle, Signal -> IO ()
handleNewTitle)
        , (Client
-> MatchRule
-> (Signal -> IO ())
-> (Signal -> IO ())
-> IO SignalHandler
I.registerForNewToolTip, Signal -> IO ()
handleNewTooltip)
        , (Client
-> MatchRule
-> (Signal -> IO ())
-> (Signal -> IO ())
-> IO SignalHandler
I.registerForNewStatus, Signal -> IO ()
handleNewStatus)
        ]

      initializeItemInfoMap = MVar (Map BusName ItemInfo)
-> (Map BusName ItemInfo -> IO (Map BusName ItemInfo, Bool))
-> IO Bool
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Map BusName ItemInfo)
itemInfoMapVar ((Map BusName ItemInfo -> IO (Map BusName ItemInfo, Bool))
 -> IO Bool)
-> (Map BusName ItemInfo -> IO (Map BusName ItemInfo, Bool))
-> IO Bool
forall a b. (a -> b) -> a -> b
$ \Map BusName ItemInfo
itemInfoMap -> do
        -- All initialization is done inside this modifyMVar to avoid race
        -- conditions with the itemInfoMapVar.
        clientSignalHandlers <- [(Client
  -> MatchRule
  -> (Signal -> IO ())
  -> (Signal -> IO ())
  -> IO SignalHandler,
  Signal -> IO ())]
-> IO [SignalHandler]
forall {b} {b}.
[(Client -> MatchRule -> b -> (Signal -> IO ()) -> IO b, b)]
-> IO [b]
registerWithPairs [(Client
  -> MatchRule
  -> (Signal -> IO ())
  -> (Signal -> IO ())
  -> IO SignalHandler,
  Signal -> IO ())]
clientRegistrationPairs
        watcherSignalHandlers <- registerWithPairs watcherRegistrationPairs
        watcherOwnerChangedHandler <-
          DTH.registerForNameOwnerChanged client matchAny handleWatcherNameOwnerChanged
        let unregisterAll =
                (SignalHandler -> IO ()) -> [SignalHandler] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Client -> SignalHandler -> IO ()
removeMatch Client
client) ([SignalHandler] -> IO ()) -> [SignalHandler] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    SignalHandler
watcherOwnerChangedHandler SignalHandler -> [SignalHandler] -> [SignalHandler]
forall a. a -> [a] -> [a]
: [SignalHandler]
clientSignalHandlers [SignalHandler] -> [SignalHandler] -> [SignalHandler]
forall a. [a] -> [a] -> [a]
++ [SignalHandler]
watcherSignalHandlers
            shutdownHost = do
                String -> IO ()
logInfo String
"Shutting down StatusNotifierHost"
                IO ()
unregisterAll
                Client -> BusName -> IO ReleaseNameReply
releaseName Client
client (String -> BusName
forall a. IsString a => String -> a
fromString String
busName)
                () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            logErrorAndShutdown a
error =
              String -> IO ()
logError (a -> String
forall a. Show a => a -> String
show a
error) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
shutdownHost IO () -> IO (Map k a, Bool) -> IO (Map k a, Bool)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Map k a, Bool) -> IO (Map k a, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map k a
forall k a. Map k a
Map.empty, Bool
False)
            finishInitialization [String]
serviceNames = do
              itemInfos <- [String] -> IO [ItemInfo]
createAll [String]
serviceNames
              let newMap = [(BusName, ItemInfo)] -> Map BusName ItemInfo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(BusName, ItemInfo)] -> Map BusName ItemInfo)
-> [(BusName, ItemInfo)] -> Map BusName ItemInfo
forall a b. (a -> b) -> a -> b
$ (ItemInfo -> (BusName, ItemInfo))
-> [ItemInfo] -> [(BusName, ItemInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (ItemInfo -> BusName
itemServiceName (ItemInfo -> BusName)
-> (ItemInfo -> ItemInfo) -> ItemInfo -> (BusName, ItemInfo)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ItemInfo -> ItemInfo
forall a. a -> a
id) [ItemInfo]
itemInfos
                  resultMap = Map BusName ItemInfo
-> Map BusName ItemInfo -> Map BusName ItemInfo
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map BusName ItemInfo
itemInfoMap Map BusName ItemInfo
newMap
              W.registerStatusNotifierHost client busName >>=
               either logErrorAndShutdown (const $ return (resultMap, True))
        W.getRegisteredStatusNotifierItems client >>=
         either logErrorAndShutdown finishInitialization

      startWatcherIfNeeded = do
        let watcherName :: String
watcherName = String -> (BusName -> String) -> Maybe BusName -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" BusName -> String
forall a b. Coercible a b => a -> b
coerce (Maybe BusName -> String) -> Maybe BusName -> String
forall a b. (a -> b) -> a -> b
$ GenerationParams -> Maybe BusName
genBusName GenerationParams
W.watcherClientGenerationParams
            startWatcher :: IO RequestNameReply
startWatcher = do
              (_, doIt) <- WatcherParams -> IO (Interface, IO RequestNameReply)
W.buildWatcher WatcherParams
W.defaultWatcherParams
              doIt
        res <- Client -> String -> IO (Either MethodError String)
DTH.getNameOwner Client
client String
watcherName
        case res of
          Right String
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Left MethodError
_ -> IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO RequestNameReply -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO RequestNameReply
startWatcher

  when shouldStartWatcher startWatcherIfNeeded
  nameRequestResult <- requestName client (fromString busName) []
  if nameRequestResult == NamePrimaryOwner
  then do
    initializationSuccess <- initializeItemInfoMap
    return $ if initializationSuccess
    then
      Just Host
      { itemInfoMap = readMVar itemInfoMapVar
      , addUpdateHandler = addHandler
      , removeUpdateHandler = removeHandler
      , forceUpdate = handleItemAdded . coerce
      }
    else Nothing
  else do
    logErrorWithMessage "Failed to obtain desired service name" nameRequestResult
    return Nothing