{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}
module StatusNotifier.Watcher.Service where

import           Control.Arrow
import           Control.Concurrent.MVar
import           Control.Monad
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Except
import           DBus
import           DBus.Client
import           DBus.Generation
import           DBus.Internal.Message as M
import           DBus.Internal.Types
import qualified DBus.Internal.Types as T
import qualified DBus.Introspection as I
import qualified DBus.TH as DBusTH
import           Data.Coerce
import           Data.Int
import           Data.List
import           Data.Maybe
import           Data.Monoid
import           Data.String
import qualified StatusNotifier.Item.Client as Item
import           StatusNotifier.Util
import           StatusNotifier.Watcher.Constants
import           StatusNotifier.Watcher.StateCache
import           StatusNotifier.Watcher.Signals
import           System.IO.Unsafe
import           System.Log.Logger
import           Text.Printf

buildWatcher :: WatcherParams -> IO (Interface, IO RequestNameReply)
buildWatcher WatcherParams
               { watcherNamespace :: WatcherParams -> String
watcherNamespace = String
interfaceNamespace
               , watcherStop :: WatcherParams -> IO ()
watcherStop = IO ()
stopWatcher
               , watcherPath :: WatcherParams -> String
watcherPath = String
path
               , watcherDBusClient :: WatcherParams -> Maybe Client
watcherDBusClient = Maybe Client
mclient
               , watcherStateCachePath :: WatcherParams -> Maybe String
watcherStateCachePath = Maybe String
maybeCachePath
               } = do
  let watcherInterfaceName :: InterfaceName
watcherInterfaceName = String -> InterfaceName
getWatcherInterfaceName String
interfaceNamespace
      logNamespace :: String
logNamespace = String
"StatusNotifier.Watcher.Service"
      logInfo :: String -> IO ()
logInfo = String -> Priority -> String -> IO ()
logM String
logNamespace Priority
INFO
      logDebug :: String -> IO ()
logDebug = String -> Priority -> String -> IO ()
logM String
logNamespace Priority
DEBUG
      logError :: String -> IO ()
logError = String -> Priority -> String -> IO ()
logM String
logNamespace Priority
ERROR
      -- Default level is now INFO (watcher/Main.hs). Keep generic per-request
      -- logging at DEBUG to avoid spamming INFO for frequent property reads.
      mkLogCb :: (t -> t IO b) -> t -> t IO b
mkLogCb t -> t IO b
cb t
msg = IO () -> t IO ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> IO ()
logDebug (t -> String
forall a. Show a => a -> String
show t
msg)) t IO () -> t IO b -> t IO b
forall a b. t IO a -> t IO b -> t IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> t -> t IO b
cb t
msg
      mkLogMethod :: Method -> Method
mkLogMethod Method
method = Method
method { methodHandler = mkLogCb $ methodHandler method }
      mkLogProperty :: MemberName -> IO v -> Property
mkLogProperty MemberName
name IO v
fn =
        MemberName -> IO v -> Property
forall v. IsValue v => MemberName -> IO v -> Property
readOnlyProperty MemberName
name (IO v -> Property) -> IO v -> Property
forall a b. (a -> b) -> a -> b
$ String -> IO ()
logDebug (MemberName -> String
forall a b. Coercible a b => a -> b
coerce MemberName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Called") IO () -> IO v -> IO v
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO v
fn

  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
  cachePath <- maybe (defaultWatcherStateCachePath interfaceNamespace path)
                     pure
                     maybeCachePath

  notifierItems <- newMVar []
  notifierHosts <- newMVar []

  let itemIsRegistered a
item t a
items =
        Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> Maybe a -> Bool
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> t a -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
item) t a
items

      persistWatcherState = do
        currentItems <- MVar [ItemEntry] -> IO [ItemEntry]
forall a. MVar a -> IO a
readMVar MVar [ItemEntry]
notifierItems
        currentHosts <- readMVar notifierHosts
        let toPersisted ItemEntry
entry =
              PersistedItemEntry
                { persistedServiceName :: String
persistedServiceName = BusName -> String
forall a b. Coercible a b => a -> b
coerce (ItemEntry -> BusName
serviceName ItemEntry
entry)
                , persistedServicePath :: String
persistedServicePath = ObjectPath -> String
forall a b. Coercible a b => a -> b
coerce (ItemEntry -> ObjectPath
servicePath ItemEntry
entry)
                }
            persistedState =
              PersistedWatcherState
                { persistedItems :: [PersistedItemEntry]
persistedItems = (ItemEntry -> PersistedItemEntry)
-> [ItemEntry] -> [PersistedItemEntry]
forall a b. (a -> b) -> [a] -> [b]
map ItemEntry -> PersistedItemEntry
toPersisted [ItemEntry]
currentItems
                , persistedHosts :: [PersistedItemEntry]
persistedHosts = (ItemEntry -> PersistedItemEntry)
-> [ItemEntry] -> [PersistedItemEntry]
forall a b. (a -> b) -> [a] -> [b]
map ItemEntry -> PersistedItemEntry
toPersisted [ItemEntry]
currentHosts
                }
        writePersistedWatcherState cachePath persistedState >>=
          either
            (\String
err ->
               String -> IO ()
logError (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                 String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Failed to persist watcher state to %s: %s" String
cachePath String
err
            )
            (const $ return ())

      renderServiceName :: ItemEntry -> String
      renderServiceName ItemEntry { serviceName :: ItemEntry -> BusName
serviceName = BusName
busName
                                  , servicePath :: ItemEntry -> ObjectPath
servicePath = ObjectPath
path
                                  } =
        let bus :: String
bus = (BusName -> String
forall a b. Coercible a b => a -> b
coerce BusName
busName :: String)
            objPath :: String
objPath = (ObjectPath -> String
forall a b. Coercible a b => a -> b
coerce ObjectPath
path :: String)
            defaultPath :: String
defaultPath = (ObjectPath -> String
forall a b. Coercible a b => a -> b
coerce ObjectPath
Item.defaultPath :: String)
        in if String
objPath String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
defaultPath
           then String
bus
           else String
bus String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
objPath

      resolveOwner BusName
bus
        | String
":" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (BusName -> String
forall a b. Coercible a b => a -> b
coerce BusName
bus :: String) = Maybe BusName -> IO (Maybe BusName)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
bus)
        | Bool
otherwise = do
            result <- Client -> String -> IO (Either MethodError String)
DBusTH.getNameOwner Client
client (BusName -> String
forall a b. Coercible a b => a -> b
coerce BusName
bus)
            return $ busName_ <$> either (const Nothing) Just result

      insertItemNoSignal Maybe BusName
owner ItemEntry
item [ItemEntry]
currentItems = do
        ownerPathMatches <-
          case Maybe BusName
owner of
            Maybe BusName
Nothing -> [ItemEntry] -> IO [ItemEntry]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            Just BusName
itemOwner ->
              (ItemEntry -> IO Bool) -> [ItemEntry] -> IO [ItemEntry]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM
                (\ItemEntry
existingItem ->
                   if ItemEntry -> ObjectPath
servicePath ItemEntry
existingItem ObjectPath -> ObjectPath -> Bool
forall a. Eq a => a -> a -> Bool
== ItemEntry -> ObjectPath
servicePath ItemEntry
item
                     then do
                       existingOwner <- BusName -> IO (Maybe BusName)
resolveOwner (ItemEntry -> BusName
serviceName ItemEntry
existingItem)
                       return $ existingOwner == Just itemOwner
                     else Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                )
                [ItemEntry]
currentItems
        if itemIsRegistered item currentItems
          then return (currentItems, False)
          else
            if null ownerPathMatches
              then return (item : currentItems, True)
              else
                let removeMatches =
                      ([ItemEntry] -> ItemEntry -> [ItemEntry])
-> [ItemEntry] -> [ItemEntry] -> [ItemEntry]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((ItemEntry -> [ItemEntry] -> [ItemEntry])
-> [ItemEntry] -> ItemEntry -> [ItemEntry]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ItemEntry -> [ItemEntry] -> [ItemEntry]
forall a. Eq a => a -> [a] -> [a]
delete) [ItemEntry]
currentItems [ItemEntry]
ownerPathMatches
                in return (item : removeMatches, True)

      insertHostNoSignal a
host [a]
currentHosts =
        if a -> [a] -> Bool
forall {t :: * -> *} {a}. (Foldable t, Eq a) => a -> t a -> Bool
itemIsRegistered a
host [a]
currentHosts
          then ([a]
currentHosts, Bool
False)
          else (a
host a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
currentHosts, Bool
True)

      parsePersistedItemEntry PersistedItemEntry
persistedEntry = do
        parsedBusName <- String -> m BusName
forall (m :: * -> *). MonadThrow m => String -> m BusName
T.parseBusName (PersistedItemEntry -> String
persistedServiceName PersistedItemEntry
persistedEntry)
        parsedPath <- T.parseObjectPath (persistedServicePath persistedEntry)
        return ItemEntry
          { serviceName = parsedBusName
          , servicePath = parsedPath
          }

      statusNotifierItemInterfaceName = String -> InterfaceName
forall a. IsString a => String -> a
fromString String
"org.kde.StatusNotifierItem"
      hasStatusNotifierItemInterface Object
objectInfo =
        (Interface -> Bool) -> [Interface] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((InterfaceName -> InterfaceName -> Bool
forall a. Eq a => a -> a -> Bool
== InterfaceName
statusNotifierItemInterfaceName) (InterfaceName -> Bool)
-> (Interface -> InterfaceName) -> Interface -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> InterfaceName
I.interfaceName) ([Interface] -> Bool) -> [Interface] -> Bool
forall a b. (a -> b) -> a -> b
$
        Object -> [Interface]
I.objectInterfaces Object
objectInfo

      validatePersistedItem PersistedItemEntry
persistedEntry =
        case PersistedItemEntry -> Maybe ItemEntry
forall {m :: * -> *}.
MonadThrow m =>
PersistedItemEntry -> m ItemEntry
parsePersistedItemEntry PersistedItemEntry
persistedEntry of
          Maybe ItemEntry
Nothing -> do
            String -> IO ()
logError (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Dropping unparsable cached item entry: %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
              PersistedItemEntry -> String
forall a. Show a => a -> String
show PersistedItemEntry
persistedEntry
            Maybe (ItemEntry, BusName) -> IO (Maybe (ItemEntry, BusName))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ItemEntry, BusName)
forall a. Maybe a
Nothing
          Just ItemEntry
item -> do
            owner <- BusName -> IO (Maybe BusName)
resolveOwner (ItemEntry -> BusName
serviceName ItemEntry
item)
            case owner of
              Maybe BusName
Nothing -> do
                String -> IO ()
logInfo (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                  String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Dropping cached item %s because the bus name is no longer owned."
                    (ItemEntry -> String
renderServiceName ItemEntry
item)
                Maybe (ItemEntry, BusName) -> IO (Maybe (ItemEntry, BusName))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ItemEntry, BusName)
forall a. Maybe a
Nothing
              Just BusName
validOwner -> do
                objectResult <-
                  Client
-> BusName -> ObjectPath -> IO (Either MethodError (Maybe Object))
getInterfaceAt Client
client (ItemEntry -> BusName
serviceName ItemEntry
item) (ItemEntry -> ObjectPath
servicePath ItemEntry
item)
                case objectResult of
                  Right (Just Object
objectInfo)
                    | Object -> Bool
hasStatusNotifierItemInterface Object
objectInfo ->
                        Maybe (ItemEntry, BusName) -> IO (Maybe (ItemEntry, BusName))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ItemEntry, BusName) -> IO (Maybe (ItemEntry, BusName)))
-> Maybe (ItemEntry, BusName) -> IO (Maybe (ItemEntry, BusName))
forall a b. (a -> b) -> a -> b
$ (ItemEntry, BusName) -> Maybe (ItemEntry, BusName)
forall a. a -> Maybe a
Just (ItemEntry
item, BusName
validOwner)
                  Either MethodError (Maybe Object)
_ -> do
                    String -> IO ()
logInfo (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                      String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Dropping cached item %s because it no longer exposes org.kde.StatusNotifierItem."
                        (ItemEntry -> String
renderServiceName ItemEntry
item)
                    Maybe (ItemEntry, BusName) -> IO (Maybe (ItemEntry, BusName))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ItemEntry, BusName)
forall a. Maybe a
Nothing

      validatePersistedHost PersistedItemEntry
persistedEntry =
        case PersistedItemEntry -> Maybe ItemEntry
forall {m :: * -> *}.
MonadThrow m =>
PersistedItemEntry -> m ItemEntry
parsePersistedItemEntry PersistedItemEntry
persistedEntry of
          Maybe ItemEntry
Nothing -> do
            String -> IO ()
logError (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Dropping unparsable cached host entry: %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
              PersistedItemEntry -> String
forall a. Show a => a -> String
show PersistedItemEntry
persistedEntry
            Maybe ItemEntry -> IO (Maybe ItemEntry)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ItemEntry
forall a. Maybe a
Nothing
          Just ItemEntry
host -> do
            owner <- BusName -> IO (Maybe BusName)
resolveOwner (ItemEntry -> BusName
serviceName ItemEntry
host)
            if isNothing owner
              then do
                logInfo $
                  printf "Dropping cached host %s because the bus name is no longer owned."
                    (coerce (serviceName host) :: String)
                return Nothing
              else return $ Just host

      restoreWatcherStateFromCache = do
        stateResult <- String -> IO (Either String (Maybe PersistedWatcherState))
readPersistedWatcherState String
cachePath
        case stateResult of
          Left String
err -> do
            String -> IO ()
logError (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Failed to read watcher cache state from %s: %s" String
cachePath String
err
            ([ItemEntry], [ItemEntry]) -> IO ([ItemEntry], [ItemEntry])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
          Right Maybe PersistedWatcherState
Nothing -> ([ItemEntry], [ItemEntry]) -> IO ([ItemEntry], [ItemEntry])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
          Right (Just PersistedWatcherState
persistedState) -> do
            validItems <- [Maybe (ItemEntry, BusName)] -> [(ItemEntry, BusName)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ItemEntry, BusName)] -> [(ItemEntry, BusName)])
-> IO [Maybe (ItemEntry, BusName)] -> IO [(ItemEntry, BusName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PersistedItemEntry -> IO (Maybe (ItemEntry, BusName)))
-> [PersistedItemEntry] -> IO [Maybe (ItemEntry, BusName)]
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 PersistedItemEntry -> IO (Maybe (ItemEntry, BusName))
validatePersistedItem (PersistedWatcherState -> [PersistedItemEntry]
persistedItems PersistedWatcherState
persistedState)
            validHosts <- catMaybes <$> mapM validatePersistedHost (persistedHosts persistedState)

            restoredItems <-
              modifyMVar notifierItems $ \[ItemEntry]
currentItems -> do
                (newItems, insertedItemsRev) <-
                  (([ItemEntry], [ItemEntry])
 -> (ItemEntry, BusName) -> IO ([ItemEntry], [ItemEntry]))
-> ([ItemEntry], [ItemEntry])
-> [(ItemEntry, BusName)]
-> IO ([ItemEntry], [ItemEntry])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
                    (\([ItemEntry]
accItems, [ItemEntry]
accInserted) (ItemEntry
item, BusName
itemOwner) -> do
                       (nextItems, inserted) <- Maybe BusName -> ItemEntry -> [ItemEntry] -> IO ([ItemEntry], Bool)
insertItemNoSignal (BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
itemOwner) ItemEntry
item [ItemEntry]
accItems
                       if inserted
                         then return (nextItems, item : accInserted)
                         else return (nextItems, accInserted)
                    )
                    ([ItemEntry]
currentItems, [])
                    [(ItemEntry, BusName)]
validItems
                return (newItems, reverse insertedItemsRev)

            restoredHosts <-
              modifyMVar notifierHosts $ \[ItemEntry]
currentHosts -> do
                let insertHost :: ([a], [a]) -> a -> ([a], [a])
insertHost ([a]
accHosts, [a]
accInserted) a
host =
                      let ([a]
nextHosts, Bool
inserted) = a -> [a] -> ([a], Bool)
forall {a}. Eq a => a -> [a] -> ([a], Bool)
insertHostNoSignal a
host [a]
accHosts
                      in if Bool
inserted
                           then ([a]
nextHosts, a
host a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
accInserted)
                           else ([a]
nextHosts, [a]
accInserted)
                    ([ItemEntry]
newHosts, [ItemEntry]
insertedHostsRev) = (([ItemEntry], [ItemEntry])
 -> ItemEntry -> ([ItemEntry], [ItemEntry]))
-> ([ItemEntry], [ItemEntry])
-> [ItemEntry]
-> ([ItemEntry], [ItemEntry])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([ItemEntry], [ItemEntry])
-> ItemEntry -> ([ItemEntry], [ItemEntry])
forall {a}. Eq a => ([a], [a]) -> a -> ([a], [a])
insertHost ([ItemEntry]
currentHosts, []) [ItemEntry]
validHosts
                ([ItemEntry], [ItemEntry]) -> IO ([ItemEntry], [ItemEntry])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ItemEntry]
newHosts, [ItemEntry] -> [ItemEntry]
forall a. [a] -> [a]
reverse [ItemEntry]
insertedHostsRev)

            persistWatcherState
            return (restoredItems, restoredHosts)

      registerStatusNotifierItem MethodCall
                                   { methodCallSender :: MethodCall -> Maybe BusName
methodCallSender = Maybe BusName
sender }
                                 String
name = ExceptT Reply IO () -> IO (Either Reply ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Reply IO () -> IO (Either Reply ()))
-> ExceptT Reply IO () -> IO (Either Reply ())
forall a b. (a -> b) -> a -> b
$ do
        let parsedBusName :: Maybe BusName
parsedBusName = String -> Maybe BusName
forall (m :: * -> *). MonadThrow m => String -> m BusName
T.parseBusName String
name
            parseServiceError :: Reply
parseServiceError = ErrorName -> String -> Reply
makeErrorReply ErrorName
errorInvalidParameters (String -> Reply) -> String -> Reply
forall a b. (a -> b) -> a -> b
$
              String -> String -> String
forall r. PrintfType r => String -> r
printf String
"the provided service %s could not be parsed \
                     \as a bus name or an object path." String
name
            senderMissingError :: Reply
senderMissingError = ErrorName -> String -> Reply
makeErrorReply ErrorName
errorInvalidParameters (String -> Reply) -> String -> Reply
forall a b. (a -> b) -> a -> b
$
              String
"Unable to identify sender for registration."
            path :: ObjectPath
path = ObjectPath -> Maybe ObjectPath -> ObjectPath
forall a. a -> Maybe a -> a
fromMaybe ObjectPath
Item.defaultPath (Maybe ObjectPath -> ObjectPath) -> Maybe ObjectPath -> ObjectPath
forall a b. (a -> b) -> a -> b
$ String -> Maybe ObjectPath
forall (m :: * -> *). MonadThrow m => String -> m ObjectPath
T.parseObjectPath String
name
            remapErrorName :: Either MethodError d -> Either Reply d
remapErrorName =
              (MethodError -> Reply) -> Either MethodError d -> Either Reply d
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ((MethodError -> Reply) -> Either MethodError d -> Either Reply d)
-> (MethodError -> Reply) -> Either MethodError d -> Either Reply d
forall a b. (a -> b) -> a -> b
$ (ErrorName -> String -> Reply
`makeErrorReply` String
"Failed to verify ownership.") (ErrorName -> Reply)
-> (MethodError -> ErrorName) -> MethodError -> Reply
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                   MethodError -> ErrorName
M.methodErrorName
        Bool -> ExceptT Reply IO () -> ExceptT Reply IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe BusName -> Bool
forall a. Maybe a -> Bool
isNothing Maybe BusName
parsedBusName Bool -> Bool -> Bool
&& Maybe ObjectPath -> Bool
forall a. Maybe a -> Bool
isNothing (String -> Maybe ObjectPath
forall (m :: * -> *). MonadThrow m => String -> m ObjectPath
T.parseObjectPath String
name)) (ExceptT Reply IO () -> ExceptT Reply IO ())
-> ExceptT Reply IO () -> ExceptT Reply IO ()
forall a b. (a -> b) -> a -> b
$
          Reply -> ExceptT Reply IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Reply
parseServiceError
        senderName <- IO (Either Reply BusName) -> ExceptT Reply IO BusName
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Reply BusName) -> ExceptT Reply IO BusName)
-> IO (Either Reply BusName) -> ExceptT Reply IO BusName
forall a b. (a -> b) -> a -> b
$ Either Reply BusName -> IO (Either Reply BusName)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Reply BusName -> IO (Either Reply BusName))
-> Either Reply BusName -> IO (Either Reply BusName)
forall a b. (a -> b) -> a -> b
$ Reply -> Maybe BusName -> Either Reply BusName
forall b a. b -> Maybe a -> Either b a
maybeToEither Reply
senderMissingError Maybe BusName
sender
        busName <-
          case parsedBusName of
            Just BusName
providedBusName -> do
              owner <- IO (Either Reply String) -> ExceptT Reply IO String
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Reply String) -> ExceptT Reply IO String)
-> IO (Either Reply String) -> ExceptT Reply IO String
forall a b. (a -> b) -> a -> b
$ Either MethodError String -> Either Reply String
forall {d}. Either MethodError d -> Either Reply d
remapErrorName (Either MethodError String -> Either Reply String)
-> IO (Either MethodError String) -> IO (Either Reply String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                       Client -> String -> IO (Either MethodError String)
DBusTH.getNameOwner Client
client (BusName -> String
forall a b. Coercible a b => a -> b
coerce BusName
providedBusName)
              unless (owner == coerce senderName) $
                throwE $ makeErrorReply errorInvalidParameters $
                  printf "Sender %s does not own service %s."
                    (coerce senderName :: String)
                    name
              return providedBusName
            Maybe BusName
Nothing -> BusName -> ExceptT Reply IO BusName
forall a. a -> ExceptT Reply IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BusName
senderName
        let item = ItemEntry { serviceName :: BusName
serviceName = BusName
busName
                             , servicePath :: ObjectPath
servicePath = ObjectPath
path
                             }
        changed <- lift $ modifyMVar notifierItems $ \[ItemEntry]
currentItems -> do
          (newItems, inserted) <- Maybe BusName -> ItemEntry -> [ItemEntry] -> IO ([ItemEntry], Bool)
insertItemNoSignal (BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
senderName) ItemEntry
item [ItemEntry]
currentItems
          return (newItems, inserted)
        lift $
          when changed $ do
            logInfo $ printf "Registered item %s." (renderServiceName item)
            emitStatusNotifierItemRegistered client $ renderServiceName item
            persistWatcherState

      registerStatusNotifierHost String
name =
        let item :: ItemEntry
item = ItemEntry { serviceName :: BusName
serviceName = String -> BusName
busName_ String
name
                             , servicePath :: ObjectPath
servicePath = ObjectPath
"/StatusNotifierHost"
                             } in
        do
          changed <- MVar [ItemEntry]
-> ([ItemEntry] -> IO ([ItemEntry], Bool)) -> IO Bool
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar [ItemEntry]
notifierHosts (([ItemEntry] -> IO ([ItemEntry], Bool)) -> IO Bool)
-> ([ItemEntry] -> IO ([ItemEntry], Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \[ItemEntry]
currentHosts ->
            let ([ItemEntry]
newHosts, Bool
inserted) = ItemEntry -> [ItemEntry] -> ([ItemEntry], Bool)
forall {a}. Eq a => a -> [a] -> ([a], Bool)
insertHostNoSignal ItemEntry
item [ItemEntry]
currentHosts
            in ([ItemEntry], Bool) -> IO ([ItemEntry], Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ItemEntry]
newHosts, Bool
inserted)
          when changed $ do
            logInfo $ printf "Registered host %s." name
            emitStatusNotifierHostRegistered client
            persistWatcherState

      registeredStatusNotifierItems :: IO [String]
      registeredStatusNotifierItems =
        (ItemEntry -> String) -> [ItemEntry] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ItemEntry -> String
renderServiceName ([ItemEntry] -> [String]) -> IO [ItemEntry] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar [ItemEntry] -> IO [ItemEntry]
forall a. MVar a -> IO a
readMVar MVar [ItemEntry]
notifierItems

      registeredSNIEntries :: IO [(String, String)]
      registeredSNIEntries =
        (ItemEntry -> (String, String))
-> [ItemEntry] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map ItemEntry -> (String, String)
forall {a} {b}.
(Coercible a String, Coercible b String) =>
ItemEntry -> (a, b)
getTuple ([ItemEntry] -> [(String, String)])
-> IO [ItemEntry] -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar [ItemEntry] -> IO [ItemEntry]
forall a. MVar a -> IO a
readMVar MVar [ItemEntry]
notifierItems
          where getTuple :: ItemEntry -> (a, b)
getTuple (ItemEntry BusName
bname ObjectPath
path) = (BusName -> a
forall a b. Coercible a b => a -> b
coerce BusName
bname, ObjectPath -> b
forall a b. Coercible a b => a -> b
coerce ObjectPath
path)

      objectPathForItem :: String -> IO (Either Reply String)
      objectPathForItem String
name =
        case String -> (String, Maybe String)
splitServiceName String
name of
          (String
_, Just String
path) -> Either Reply String -> IO (Either Reply String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Reply String -> IO (Either Reply String))
-> Either Reply String -> IO (Either Reply String)
forall a b. (a -> b) -> a -> b
$ String -> Either Reply String
forall a b. b -> Either a b
Right String
path
          (String
bus, Maybe String
Nothing) ->
            Reply -> Maybe String -> Either Reply String
forall b a. b -> Maybe a -> Either b a
maybeToEither Reply
notFoundError (Maybe String -> Either Reply String)
-> ([ItemEntry] -> Maybe String)
-> [ItemEntry]
-> Either Reply String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ItemEntry -> String) -> Maybe ItemEntry -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ObjectPath -> String
forall a b. Coercible a b => a -> b
coerce (ObjectPath -> String)
-> (ItemEntry -> ObjectPath) -> ItemEntry -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ItemEntry -> ObjectPath
servicePath) (Maybe ItemEntry -> Maybe String)
-> ([ItemEntry] -> Maybe ItemEntry) -> [ItemEntry] -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            (ItemEntry -> Bool) -> [ItemEntry] -> Maybe ItemEntry
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((BusName -> BusName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> BusName
busName_ String
bus) (BusName -> Bool) -> (ItemEntry -> BusName) -> ItemEntry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ItemEntry -> BusName
serviceName) ([ItemEntry] -> Either Reply String)
-> IO [ItemEntry] -> IO (Either Reply String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            MVar [ItemEntry] -> IO [ItemEntry]
forall a. MVar a -> IO a
readMVar MVar [ItemEntry]
notifierItems
        where notFoundError :: Reply
notFoundError =
                ErrorName -> String -> Reply
makeErrorReply ErrorName
errorInvalidParameters (String -> Reply) -> String -> Reply
forall a b. (a -> b) -> a -> b
$
                String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Service %s is not registered." String
name

      isStatusNotifierHostRegistered = Bool -> Bool
not (Bool -> Bool) -> ([ItemEntry] -> Bool) -> [ItemEntry] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ItemEntry] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([ItemEntry] -> Bool) -> IO [ItemEntry] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar [ItemEntry] -> IO [ItemEntry]
forall a. MVar a -> IO a
readMVar MVar [ItemEntry]
notifierHosts

      protocolVersion = Int32 -> IO Int32
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
0 :: IO Int32

      filterDeadService :: String -> MVar [ItemEntry] -> IO [ItemEntry]
      filterDeadService String
deadService MVar [ItemEntry]
mvar = MVar [ItemEntry]
-> ([ItemEntry] -> IO ([ItemEntry], [ItemEntry])) -> IO [ItemEntry]
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar [ItemEntry]
mvar (([ItemEntry] -> IO ([ItemEntry], [ItemEntry])) -> IO [ItemEntry])
-> ([ItemEntry] -> IO ([ItemEntry], [ItemEntry])) -> IO [ItemEntry]
forall a b. (a -> b) -> a -> b
$
        ([ItemEntry], [ItemEntry]) -> IO ([ItemEntry], [ItemEntry])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([ItemEntry], [ItemEntry]) -> IO ([ItemEntry], [ItemEntry]))
-> ([ItemEntry] -> ([ItemEntry], [ItemEntry]))
-> [ItemEntry]
-> IO ([ItemEntry], [ItemEntry])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ItemEntry -> Bool) -> [ItemEntry] -> ([ItemEntry], [ItemEntry])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((BusName -> BusName -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> BusName
busName_ String
deadService) (BusName -> Bool) -> (ItemEntry -> BusName) -> ItemEntry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ItemEntry -> BusName
serviceName)

      handleNameOwnerChanged p
_ String
name p
oldOwner a
newOwner =
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (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
          removedItems <- String -> MVar [ItemEntry] -> IO [ItemEntry]
filterDeadService String
name MVar [ItemEntry]
notifierItems
          unless (null removedItems) $ do
            logInfo $ printf "Unregistering item %s because it disappeared." name
            forM_ removedItems $ \ItemEntry
item ->
              Client -> String -> IO ()
emitStatusNotifierItemUnregistered Client
client (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ItemEntry -> String
renderServiceName ItemEntry
item
          removedHosts <- filterDeadService name notifierHosts
          unless (null removedHosts) $
            logInfo $ printf "Unregistering host %s because it disappeared." name
          when (not (null removedItems) || not (null removedHosts)) $
            persistWatcherState
          return ()

      watcherMethods = (Method -> Method) -> [Method] -> [Method]
forall a b. (a -> b) -> [a] -> [b]
map Method -> Method
mkLogMethod
        [ MemberName
-> (MethodCall -> String -> IO (Either Reply ())) -> Method
forall fn.
AutoMethod fn =>
MemberName -> (MethodCall -> fn) -> Method
autoMethodWithMsg MemberName
"RegisterStatusNotifierItem"
          MethodCall -> String -> IO (Either Reply ())
registerStatusNotifierItem
        , MemberName -> (String -> IO ()) -> Method
forall fn. AutoMethod fn => MemberName -> fn -> Method
autoMethod MemberName
"RegisterStatusNotifierHost"
          String -> IO ()
registerStatusNotifierHost
        , MemberName -> IO () -> Method
forall fn. AutoMethod fn => MemberName -> fn -> Method
autoMethod MemberName
"StopWatcher"
          IO ()
stopWatcher
        , MemberName -> (String -> IO (Either Reply String)) -> Method
forall fn. AutoMethod fn => MemberName -> fn -> Method
autoMethod MemberName
"GetObjectPathForItemName"
          String -> IO (Either Reply String)
objectPathForItem
        ]

      watcherProperties =
        [ MemberName -> IO [String] -> Property
forall v. IsValue v => MemberName -> IO v -> Property
mkLogProperty MemberName
"RegisteredStatusNotifierItems"
          IO [String]
registeredStatusNotifierItems
        , MemberName -> IO [(String, String)] -> Property
forall v. IsValue v => MemberName -> IO v -> Property
mkLogProperty MemberName
"RegisteredSNIEntries"
          IO [(String, String)]
registeredSNIEntries
        , MemberName -> IO Bool -> Property
forall v. IsValue v => MemberName -> IO v -> Property
mkLogProperty MemberName
"IsStatusNotifierHostRegistered"
          IO Bool
isStatusNotifierHostRegistered
        , MemberName -> IO Int32 -> Property
forall v. IsValue v => MemberName -> IO v -> Property
mkLogProperty MemberName
"ProtocolVersion"
          IO Int32
protocolVersion
        ]

      watcherInterface =
        Interface
        { interfaceName :: InterfaceName
interfaceName = InterfaceName
watcherInterfaceName
        , interfaceMethods :: [Method]
interfaceMethods = [Method]
watcherMethods
        , interfaceProperties :: [Property]
interfaceProperties = [Property]
watcherProperties
        , interfaceSignals :: [Signal]
interfaceSignals = [Signal]
watcherSignals
        }

      startWatcher = do
        nameRequestResult <- Client -> BusName -> [RequestNameFlag] -> IO RequestNameReply
requestName Client
client (InterfaceName -> BusName
forall a b. Coercible a b => a -> b
coerce InterfaceName
watcherInterfaceName) []
        case nameRequestResult of
          RequestNameReply
NamePrimaryOwner ->
            do
              _ <- Client
-> MatchRule
-> (Signal -> String -> String -> String -> IO ())
-> IO SignalHandler
DBusTH.registerForNameOwnerChanged Client
client
                   MatchRule
matchAny Signal -> String -> String -> String -> IO ()
forall {a} {p} {p}.
(Eq a, IsString a) =>
p -> String -> p -> a -> IO ()
handleNameOwnerChanged
              (restoredItems, restoredHosts) <- restoreWatcherStateFromCache
              export client (fromString path) watcherInterface
              logInfo $
                printf "Restored %d cached items and %d cached hosts."
                  (length restoredItems)
                  (length restoredHosts)
              mapM_ (emitStatusNotifierItemRegistered client . renderServiceName)
                restoredItems
              mapM_ (const $ emitStatusNotifierHostRegistered client) restoredHosts
          RequestNameReply
_ -> IO ()
stopWatcher
        return nameRequestResult

  return (watcherInterface, startWatcher)

-- For Client generation
-- TODO: get rid of unsafePerformIO here by making function that takes mvars so
-- IO isn't needed to build watcher
{-# NOINLINE watcherInterface #-}
watcherInterface :: Interface
watcherInterface = Interface -> Interface
buildIntrospectionInterface Interface
clientInterface
  where (Interface
clientInterface, IO RequestNameReply
_) =
          IO (Interface, IO RequestNameReply)
-> (Interface, IO RequestNameReply)
forall a. IO a -> a
unsafePerformIO (IO (Interface, IO RequestNameReply)
 -> (Interface, IO RequestNameReply))
-> IO (Interface, IO RequestNameReply)
-> (Interface, IO RequestNameReply)
forall a b. (a -> b) -> a -> b
$ WatcherParams -> IO (Interface, IO RequestNameReply)
buildWatcher
          WatcherParams
defaultWatcherParams { watcherDBusClient = Just undefined }