diff --git a/src/StatusNotifier/Host/Service.hs b/src/StatusNotifier/Host/Service.hs --- a/src/StatusNotifier/Host/Service.hs +++ b/src/StatusNotifier/Host/Service.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} module StatusNotifier.Host.Service where @@ -12,22 +13,29 @@ import Control.Monad.Except import DBus import DBus.Client +import DBus.Generation +import DBus.Internal.Types import qualified DBus.Internal.Message as M +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.Unique import Data.Word import System.Log.Logger import Text.Printf -import qualified StatusNotifier.Item.Constants as I import qualified StatusNotifier.Item.Client as I +import qualified StatusNotifier.Item.Constants 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 = "StatusNotifierHost" @@ -44,20 +52,22 @@ | TitleUpdated | TooltipUpdated deriving (Eq, Show) +type UpdateHandler = UpdateType -> ItemInfo -> IO () + data Params = Params { dbusClient :: Maybe Client , uniqueIdentifier :: String , namespace :: String - , handleUpdate :: UpdateType -> ItemInfo -> IO () - , hostLogger :: Logger + , startWatcher :: Bool } +hostLogger = logM "StatusNotifier.Host.Service" + defaultParams = Params { dbusClient = Nothing , uniqueIdentifier = "" , namespace = "org.kde" - , handleUpdate = \_ _ -> return () - , hostLogger = makeDefaultLogger "StatusNotifier.Watcher.Service" + , startWatcher = False } data ItemInfo = ItemInfo @@ -91,28 +101,48 @@ , itemServicePath = path } = fn name path -build :: Params -> IO (IO RequestNameReply) +data Host = Host + { itemInfoMap :: IO (Map.Map BusName ItemInfo) + , addUpdateHandler :: UpdateHandler -> IO Unique + , removeUpdateHandler :: Unique -> IO () + } + +build :: Params -> IO (Maybe Host) build Params { dbusClient = mclient , namespace = namespaceString , uniqueIdentifier = uniqueID - , handleUpdate = updateHandler - , hostLogger = logger + , startWatcher = shouldStartWatcher } = do client <- maybe connectSession return mclient itemInfoMapVar <- newMVar Map.empty + updateHandlersVar <- newMVar ([] :: [(Unique, UpdateHandler)]) let busName = getBusName namespaceString uniqueID - logError = logL logger ERROR + logError = hostLogger ERROR logErrorWithMessage message error = logError message >> logError (show error) - logInfo = logL logger INFO + logInfo = hostLogger INFO logErrorAndThen andThen e = logError (show e) >> andThen - doUpdate utype uinfo = - logInfo (printf "Sending update (iconPixmaps suppressed): %s %s" + doUpdateForHandler utype uinfo (unique, handler) = do + logInfo (printf "Sending update (iconPixmaps suppressed): %s %s, for handler %s" (show utype) - (show $ uinfo { iconPixmaps = [] })) >> - void (forkIO (updateHandler utype uinfo)) + (show $ uinfo { iconPixmaps = [] }) + (show $ hashUnique unique)) + forkIO $ handler utype uinfo + doUpdate utype uinfo = + readMVar updateHandlersVar >>= mapM_ (doUpdateForHandler utype uinfo) + + addHandler handler = do + unique <- newUnique + modifyMVar_ updateHandlersVar (return . ((unique, handler):)) + let doUpdateForInfo info = doUpdateForHandler ItemAdded info (unique, handler) + readMVar itemInfoMapVar >>= mapM_ doUpdateForInfo + return unique + + removeHandler unique = + modifyMVar_ updateHandlersVar (return . filter ((/= unique) . fst)) + getPixmaps a1 a2 a3 = fmap convertPixmapsToHostByteOrder <$> I.getIconPixmap a1 a2 a3 @@ -148,7 +178,7 @@ registerWithPairs = mapM (uncurry clientSignalRegister) where logUnableToCallSignal signal = - logL logger ERROR $ printf "Unable to call handler with %s" $ + hostLogger ERROR $ printf "Unable to call handler with %s" $ show signal clientSignalRegister signalRegisterFn handler = signalRegisterFn client matchAny handler logUnableToCallSignal @@ -210,7 +240,7 @@ , (I.registerForNewTitle, handleNewTitle) ] - initializeItemInfoMap = modifyMVar_ itemInfoMapVar $ \itemInfoMap -> do + initializeItemInfoMap = modifyMVar itemInfoMapVar $ \itemInfoMap -> do -- All initialization is done inside this modifyMvar to avoid race -- conditions with the itemInfoMapVar. clientSignalHandlers <- registerWithPairs clientRegistrationPairs @@ -224,23 +254,43 @@ releaseName client (fromString busName) return () logErrorAndShutdown error = - logError (show error) >> shutdownHost >> return Map.empty + logError (show error) >> shutdownHost >> return (Map.empty, False) finishInitialization serviceNames = do itemInfos <- createAll serviceNames - mapM_ (doUpdate ItemAdded) itemInfos let newMap = Map.fromList $ map (itemServiceName &&& id) itemInfos -- Extra paranoia about the map resultMap = if Map.null itemInfoMap then newMap else Map.union itemInfoMap newMap W.registerStatusNotifierHost client busName >>= - either logErrorAndShutdown (const $ return resultMap) + either logErrorAndShutdown (const $ return (resultMap, True)) W.getRegisteredStatusNotifierItems client >>= either logErrorAndShutdown finishInitialization - startup = - do - nameRequestResult <- requestName client (fromString busName) [] - when (nameRequestResult == NamePrimaryOwner) initializeItemInfoMap - return nameRequestResult - return startup + startWatcherIfNeeded = do + let watcherName = maybe "" coerce $ genBusName W.watcherClientGenerationParams + startWatcher = do + (_, doIt) <- W.buildWatcher W.defaultWatcherParams + doIt + res <- DTH.getNameOwner client watcherName + case res of + Right _ -> return () + Left _ -> void $ forkIO $ void 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 + } + else Nothing + else do + logErrorWithMessage "Failed to obtain desired service name" nameRequestResult + return Nothing + diff --git a/src/StatusNotifier/Util.hs b/src/StatusNotifier/Util.hs --- a/src/StatusNotifier/Util.hs +++ b/src/StatusNotifier/Util.hs @@ -52,7 +52,7 @@ {-# NOINLINE makeDefaultLogger #-} makeDefaultLogger :: String -> Logger makeDefaultLogger name = - setLevel INFO $ unsafePerformIO $ getLogger name + unsafePerformIO $ getLogger name logErrorWithDefault :: Show a => Logger -> b -> String -> Either a b -> IO b diff --git a/src/StatusNotifier/Watcher/Service.hs b/src/StatusNotifier/Watcher/Service.hs --- a/src/StatusNotifier/Watcher/Service.hs +++ b/src/StatusNotifier/Watcher/Service.hs @@ -27,7 +27,6 @@ import System.Log.Logger import Text.Printf - buildWatcher WatcherParams { watcherNamespace = interfaceNamespace , watcherLogger = logger diff --git a/status-notifier-item.cabal b/status-notifier-item.cabal --- a/status-notifier-item.cabal +++ b/status-notifier-item.cabal @@ -1,11 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.27.0. +-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack -- --- hash: 5031b8852f36b00720f0e3a9da94253f14e1732c28f671b766c2a75be1926610 +-- hash: 18a8456ecc7341693bf5762b5d6e0f6ff33dcb66895d73081d52ddb31b8a731c name: status-notifier-item -version: 0.1.0.0 +version: 0.2.0.0 synopsis: A wrapper over the StatusNotifierItem/libappindicator dbus specification description: Please see the README on Github at category: Desktop @@ -18,7 +18,6 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10 - extra-source-files: ChangeLog.md README.md