{-# 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)]

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
      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
        String -> IO ()
logInfo (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

      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
        pathString <- 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 -> String -> IO (Either MethodError String)
W.getObjectPathForItemName Client
client String
name
        let busName = String -> BusName
forall a. IsString a => String -> a
fromString String
name
            path = String -> ObjectPath
objectPath_ String
pathString
            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 False I.getItemIsMenu
        return ItemInfo
                 { itemServiceName = busName_ name
                 , 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

      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{Bool
String
ImageInfo
Maybe String
Maybe (String, ImageInfo, String, String)
Maybe ObjectPath
BusName
ObjectPath
itemServiceName :: ItemInfo -> BusName
itemServicePath :: ItemInfo -> ObjectPath
itemId :: ItemInfo -> Maybe String
itemStatus :: ItemInfo -> Maybe String
itemCategory :: ItemInfo -> Maybe String
itemToolTip :: ItemInfo -> Maybe (String, ImageInfo, String, String)
iconTitle :: ItemInfo -> String
iconName :: ItemInfo -> String
overlayIconName :: ItemInfo -> Maybe String
iconThemePath :: ItemInfo -> Maybe String
iconPixmaps :: ItemInfo -> ImageInfo
overlayIconPixmaps :: ItemInfo -> ImageInfo
menuPath :: ItemInfo -> Maybe ObjectPath
itemIsMenu :: ItemInfo -> Bool
itemServiceName :: BusName
itemServicePath :: ObjectPath
itemId :: Maybe String
itemStatus :: Maybe String
itemCategory :: Maybe String
itemToolTip :: Maybe (String, ImageInfo, String, String)
iconTitle :: String
iconName :: String
overlayIconName :: Maybe String
iconThemePath :: Maybe String
iconPixmaps :: ImageInfo
overlayIconPixmaps :: ImageInfo
menuPath :: Maybe ObjectPath
itemIsMenu :: Bool
..} =
                  if BusName -> Map BusName ItemInfo -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member BusName
itemServiceName 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 UpdateHandler
doUpdate UpdateType
ItemAdded ItemInfo
itemInfo 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
>>
                       Map BusName ItemInfo -> IO (Map BusName ItemInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BusName -> ItemInfo -> Map BusName ItemInfo -> Map BusName ItemInfo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BusName
itemServiceName ItemInfo
itemInfo 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 = String -> BusName
busName_ 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 =
            Priority -> String -> IO ()
hostLogger Priority
WARNING (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)
        ]

      getSender BusName -> IO ()
fn s :: Signal
s@M.Signal { signalSender :: Signal -> Maybe BusName
M.signalSender = Just BusName
sender} =
        String -> IO ()
logInfo (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
WARNING (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)
            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
>>= (Priority -> String -> IO ())
-> String
-> Either MethodError (Maybe ItemInfo)
-> IO (Maybe (Maybe ItemInfo))
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"
            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 WARNING 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 <||> 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 ()
forall {a}.
Show a =>
[BusName -> IO (Either a 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 a ItemInfo)]
updaters UpdateType
updateType p
serviceName = do
        updateResults <- ((p -> IO (Either a ItemInfo)) -> IO (Either a ItemInfo))
-> [p -> IO (Either a ItemInfo)] -> IO [Either a 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 a ItemInfo)) -> p -> IO (Either a ItemInfo)
forall a b. (a -> b) -> a -> b
$ p
serviceName) [p -> IO (Either a ItemInfo)]
updaters
        let (failures, updates) = partitionEithers updateResults
            logLevel = if [ItemInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ItemInfo]
updates then Priority
ERROR else Priority
DEBUG
        mapM_ (doUpdate updateType) updates
        when (not $ null failures) $
             hostLogger logLevel $ printf "Property update failures %s" $
                        show failures

      runUpdaters [BusName -> IO (Either a 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 a ItemInfo)]
-> UpdateType -> BusName -> IO ()
forall {a} {p}.
Show a =>
[p -> IO (Either a ItemInfo)] -> UpdateType -> p -> IO ()
runUpdatersForService [BusName -> IO (Either a 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 ()
forall {a}.
Show a =>
[BusName -> IO (Either a 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 ()
forall {a}.
Show a =>
[BusName -> IO (Either a 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
        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]
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