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 @@ -80,16 +80,8 @@ , menuPath :: Maybe ObjectPath } deriving (Eq, Show) -defaultItemInfo = - ItemInfo - { itemServiceName = "a.b" - , itemServicePath = "/" - , iconThemePath = Nothing - , iconName = "" - , iconTitle = "" - , iconPixmaps = [] - , menuPath = Nothing - } +supressPixelData info = + info { iconPixmaps = map (\(w, h, _) -> (w, h, "")) $ iconPixmaps info } makeLensesWithLSuffix ''ItemInfo @@ -127,7 +119,7 @@ doUpdateForHandler utype uinfo (unique, handler) = do logInfo (printf "Sending update (iconPixmaps suppressed): %s %s, for handler %s" (show utype) - (show $ uinfo { iconPixmaps = [] }) + (show $ supressPixelData uinfo) (show $ hashUnique unique)) forkIO $ handler utype uinfo @@ -196,9 +188,16 @@ maybe I.defaultPath itemServicePath . Map.lookup name <$> readMVar itemInfoMapVar - handleItemRemoved serviceName = let busName = busName_ serviceName in - modifyMVar_ itemInfoMapVar (return . Map.delete busName ) >> - doUpdate ItemRemoved defaultItemInfo { itemServiceName = busName } + handleItemRemoved serviceName = + modifyMVar itemInfoMapVar doRemove >>= + maybe logNonExistantRemoval (doUpdate ItemRemoved) + where + busName = busName_ serviceName + doRemove currentMap = + return (Map.delete busName currentMap, Map.lookup busName currentMap) + logNonExistantRemoval = + hostLogger WARNING $ printf "Attempt to remove unknown item %s" $ + show busName watcherRegistrationPairs = [ (W.registerForStatusNotifierItemRegistered, const handleItemAdded) @@ -211,30 +210,71 @@ logPropError = logErrorWithMessage "Error updating property: " - makeUpdaterFromProp = makeUpdaterFromProp' logPropError + runProperty prop serviceName = + getObjectPathForItemName serviceName >>= prop client serviceName - makeUpdaterFromProp' onError lens updateType prop = getSender run - where run sender = - getObjectPathForItemName sender >>= - prop client sender >>= - either onError (runUpdate lens updateType sender) + logUnknownSender updateType signal = + hostLogger WARNING $ + printf "Got signal for update type: %s from unknown sender: %s" + (show updateType) (show signal) - runUpdate lens updateType sender newValue = - modifyMVar itemInfoMapVar modify >>= callUpdate - where modify infoMap = - let newMap = set (at sender . non defaultItemInfo . lens) - newValue infoMap - in return (newMap, Map.lookup sender newMap) - callUpdate = flip whenJust (doUpdate updateType) + logErrorsUpdater lens updateType prop signal = + makeUpdaterFromProp lens updateType prop signal >>= + either logPropError ((flip when logSenderErrorAndUpdateAll) . isNothing) + where + logSenderErrorAndUpdateAll = do + logUnknownSender updateType signal + void $ updatePropertyForAllItemInfos lens updateType prop - updatePixmaps = + makeUpdaterFromProp lens updateType prop + signal@M.Signal { M.signalSender = Just sender} = + runExceptT $ + ExceptT (runProperty prop sender) >>= + lift . runUpdateOfProperty lens updateType sender + makeUpdaterFromProp _ _ _ _ = return $ Right Nothing + + runUpdateOfProperty lens updateType serviceName newValue = do + maybeServiceInfo <- modifyMVar itemInfoMapVar modify + whenJust maybeServiceInfo (doUpdate updateType) + return maybeServiceInfo + where + modify infoMap = + let newMap = set (at serviceName . _Just . lens) newValue infoMap + in return (newMap, Map.lookup serviceName newMap) + + updatePropertyForAllItemInfos lens updateType prop = do + readMVar itemInfoMapVar >>= mapM (runUpdateForService . itemServiceName) + where runUpdateForService serviceName = + runProperty prop serviceName >>= + either (const $ return ()) + (void . runUpdateOfProperty lens updateType serviceName) + + updateAllIcons = + updatePropertyForAllItemInfos iconPixmapsL IconUpdated getPixmaps >> + updatePropertyForAllItemInfos iconNameL IconNameUpdated I.getIconName + + handleNewPixmaps = makeUpdaterFromProp iconPixmapsL IconUpdated getPixmaps - handleNewIcon signal = - makeUpdaterFromProp' - (const $ updatePixmaps signal) - iconNameL IconNameUpdated I.getIconName signal + handleNewIconName = + makeUpdaterFromProp iconNameL IconNameUpdated I.getIconName + handleNewIcon signal = do + newNameResult <- handleNewIconName signal + newPixmapsResult <- handleNewPixmaps signal + let remPD = right (fmap supressPixelData) + result = (remPD newNameResult, remPD newPixmapsResult) + debugLog = hostLogger DEBUG $ printf "Icon update results %s" (show result) + updateAll = logUnknownSender IconUpdated signal >> void updateAllIcons + gotProp = rights [newNameResult, newPixmapsResult] + fullSuccess = catMaybes gotProp + if null fullSuccess + then if null gotProp + then hostLogger WARNING $ printf + "Failed to load new icon with either method %s" + (show result) + else updateAll + else debugLog handleNewTitle = - makeUpdaterFromProp iconTitleL TitleUpdated I.getTitle + logErrorsUpdater iconTitleL TitleUpdated I.getTitle clientRegistrationPairs = [ (I.registerForNewIcon, handleNewIcon) diff --git a/src/StatusNotifier/Util.hs b/src/StatusNotifier/Util.hs --- a/src/StatusNotifier/Util.hs +++ b/src/StatusNotifier/Util.hs @@ -4,14 +4,16 @@ import Control.Arrow import Control.Lens import DBus.Client +import qualified DBus.Generation as G import qualified DBus.Internal.Message as M import qualified DBus.Internal.Types as T import qualified DBus.Introspection as I -import qualified DBus.Generation as G +import Data.Bits import qualified Data.ByteString as BS import Data.Maybe import qualified Data.Vector.Storable as VS import Data.Vector.Storable.ByteString +import Data.Word import Language.Haskell.TH import Network.Socket (ntohl) import StatusNotifier.TH @@ -49,9 +51,17 @@ whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenJust = flip $ maybe $ return () +convertARGBToABGR :: Word32 -> Word32 +convertARGBToABGR bits = (blue `shift` 16) .|. (red `shift` (-16)) .|. green .|. alpha + where + blue = bits .&. 0xFF + green = bits .&. 0xFF00 + red = bits .&. 0xFF0000 + alpha = bits .&. 0xFF000000 + networkToSystemByteOrder :: BS.ByteString -> BS.ByteString networkToSystemByteOrder original = - vectorToByteString $ VS.map ntohl $ byteStringToVector original + vectorToByteString $ VS.map (convertARGBToABGR . ntohl) $ byteStringToVector original maybeToEither :: b -> Maybe a -> Either b a maybeToEither = flip maybe Right . Left 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.28.2. +-- This file has been generated from package.yaml by hpack version 0.21.2. -- -- see: https://github.com/sol/hpack -- --- hash: fab14775734399bef953c7eccd528496b0abd4ae265b3f999bf78e2ee151b2b4 +-- hash: 0c0d886a82dbaa1abe2f1122ced43a208b5f1e3444653dbbe36e8f2fc564a729 name: status-notifier-item -version: 0.2.2.0 +version: 0.2.2.1 synopsis: A wrapper over the StatusNotifierItem/libappindicator dbus specification description: Please see the README on Github at category: Desktop @@ -18,6 +18,7 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10 + extra-source-files: ChangeLog.md README.md