{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module StatusNotifier.Host.Service where
import Control.Arrow
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Lens
import Control.Lens.Tuple
import Control.Monad
import Control.Monad.Except
import DBus
import DBus.Client
import qualified DBus.Internal.Message as M
import qualified Data.ByteString as BS
import Data.Either
import Data.Int
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.String
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 StatusNotifier.Util
import qualified StatusNotifier.Watcher.Client as W
import qualified StatusNotifier.Watcher.Signals as W
statusNotifierHostString :: String
statusNotifierHostString = "StatusNotifierHost"
getBusName :: String -> String -> String
getBusName namespace =
printf "%s.%s-%s" namespace statusNotifierHostString
data UpdateType
= ItemAdded
| ItemRemoved
| IconUpdated
| IconNameUpdated
| TitleUpdated
| TooltipUpdated deriving (Eq, Show)
data Params = Params
{ dbusClient :: Maybe Client
, uniqueIdentifier :: String
, namespace :: String
, handleUpdate :: UpdateType -> ItemInfo -> IO ()
, hostLogger :: Logger
}
defaultParams = Params
{ dbusClient = Nothing
, uniqueIdentifier = ""
, namespace = "org.kde"
, handleUpdate = \_ _ -> return ()
, hostLogger = makeDefaultLogger "StatusNotifier.Watcher.Service"
}
data ItemInfo = ItemInfo
{ itemServiceName :: BusName
, itemServicePath :: ObjectPath
, iconTitle :: String
, iconName :: String
, iconThemePath :: Maybe String
, iconPixmaps :: [(Int32, Int32, BS.ByteString)]
, menuPath :: Maybe ObjectPath
} deriving (Eq, Show)
defaultItemInfo =
ItemInfo
{ itemServiceName = "a.b"
, itemServicePath = "/"
, iconThemePath = Nothing
, iconName = ""
, iconTitle = ""
, iconPixmaps = []
, menuPath = Nothing
}
makeLensesWithLSuffix ''ItemInfo
convertPixmapsToHostByteOrder ::
[(Int32, Int32, BS.ByteString)] -> [(Int32, Int32, BS.ByteString)]
convertPixmapsToHostByteOrder = map $ over _3 networkToSystemByteOrder
callFromInfo fn ItemInfo { itemServiceName = name
, itemServicePath = path
} = fn name path
build :: Params -> IO (IO RequestNameReply)
build Params { dbusClient = mclient
, namespace = namespaceString
, uniqueIdentifier = uniqueID
, handleUpdate = updateHandler
, hostLogger = logger
} = do
client <- maybe connectSession return mclient
itemInfoMapVar <- newMVar Map.empty
let busName = getBusName namespaceString uniqueID
logError = logL logger ERROR
logErrorWithMessage message error = logError message >> logError (show error)
logInfo = logL logger INFO
logErrorAndThen andThen e = logError (show e) >> andThen
doUpdate utype uinfo =
logInfo (printf "Sending update (iconPixmaps suppressed): %s %s"
(show utype)
(show $ uinfo { iconPixmaps = [] })) >>
void (forkIO (updateHandler utype uinfo))
getPixmaps a1 a2 a3 = fmap convertPixmapsToHostByteOrder <$>
I.getIconPixmap a1 a2 a3
buildItemInfo name = runExceptT $ do
pathString <- ExceptT $ W.getObjectPathForItemName client name
let busName = fromString name
path = objectPath_ pathString
getMaybe fn a b c = right Just <$> fn a b c
doGetDef def fn =
ExceptT $ exemptAll def <$> fn client busName path
doGet fn = ExceptT $ fn client busName path
pixmaps <- doGetDef [] getPixmaps
iName <- doGetDef name I.getIconName
themePath <- doGetDef Nothing $ getMaybe I.getIconThemePath
menu <- doGetDef Nothing $ getMaybe I.getMenu
title <- doGetDef "" I.getTitle
return ItemInfo
{ itemServiceName = busName_ name
, itemServicePath = path
, iconPixmaps = pixmaps
, iconThemePath = themePath
, iconName = iName
, iconTitle = title
, menuPath = menu
}
createAll serviceNames = do
(errors, itemInfos) <-
partitionEithers <$> mapM buildItemInfo serviceNames
mapM_ (logErrorWithMessage "Error in item building at startup:") errors
return itemInfos
registerWithPairs =
mapM (uncurry clientSignalRegister)
where logUnableToCallSignal signal =
logL logger ERROR $ printf "Unable to call handler with %s" $
show signal
clientSignalRegister signalRegisterFn handler =
signalRegisterFn client matchAny handler logUnableToCallSignal
handleItemAdded _ serviceName =
modifyMVar_ itemInfoMapVar $ \itemInfoMap ->
buildItemInfo serviceName >>=
either (logErrorAndThen $ return itemInfoMap)
(addItemInfo itemInfoMap)
where addItemInfo map itemInfo = doUpdate ItemAdded itemInfo >>
return (Map.insert (itemServiceName itemInfo) itemInfo map)
getObjectPathForItemName name =
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 }
watcherRegistrationPairs =
[ (W.registerForStatusNotifierItemRegistered, handleItemAdded)
, (W.registerForStatusNotifierItemUnregistered, handleItemRemoved)
]
getSender fn s@M.Signal { M.signalSender = Just sender} =
logInfo (show s) >> fn sender
getSender _ s = logError $ "Received signal with no sender: " ++ show s
logPropError = logErrorWithMessage "Error updating property: "
makeUpdaterFromProp = makeUpdaterFromProp' logPropError
makeUpdaterFromProp' onError lens updateType prop = getSender run
where run sender =
getObjectPathForItemName sender >>=
prop client sender >>=
either onError (runUpdate lens updateType sender)
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)
updatePixmaps =
makeUpdaterFromProp iconPixmapsL IconUpdated getPixmaps
handleNewIcon signal =
makeUpdaterFromProp'
(const $ updatePixmaps signal)
iconNameL IconNameUpdated I.getIconName signal
handleNewTitle =
makeUpdaterFromProp iconTitleL TitleUpdated I.getTitle
clientRegistrationPairs =
[ (I.registerForNewIcon, handleNewIcon)
, (I.registerForNewTitle, handleNewTitle)
]
initializeItemInfoMap = modifyMVar_ itemInfoMapVar $ \itemInfoMap -> do
clientSignalHandlers <- registerWithPairs clientRegistrationPairs
watcherSignalHandlers <- registerWithPairs watcherRegistrationPairs
let unregisterAll =
mapM_ (removeMatch client) $
clientSignalHandlers ++ watcherSignalHandlers
shutdownHost = do
logInfo "Shutting down StatusNotifierHost"
unregisterAll
releaseName client (fromString busName)
return ()
logErrorAndShutdown error =
logError (show error) >> shutdownHost >> return Map.empty
finishInitialization serviceNames = do
itemInfos <- createAll serviceNames
mapM_ (doUpdate ItemAdded) itemInfos
let newMap = Map.fromList $ map (itemServiceName &&& id) itemInfos
resultMap = if Map.null itemInfoMap
then newMap
else Map.union itemInfoMap newMap
W.registerStatusNotifierHost client busName >>=
either logErrorAndShutdown (const $ return resultMap)
W.getRegisteredStatusNotifierItems client >>=
either logErrorAndShutdown finishInitialization
startup =
do
nameRequestResult <- requestName client (fromString busName) []
when (nameRequestResult == NamePrimaryOwner) initializeItemInfoMap
return nameRequestResult
return startup