    {-# 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.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
                   } = do
      let watcherInterfaceName :: InterfaceName
    watcherInterfaceName = String -> InterfaceName
    getWatcherInterfaceName String
    interfaceNamespace
          logNamespace :: String
    logNamespace = String
    "StatusNotifier.Watcher.Service"
          log :: String -> IO ()
    log = String -> Priority -> String -> IO ()
    logM String
    logNamespace  Priority
    INFO
          logError :: String -> IO ()
    logError = String -> Priority -> String -> IO ()
    logM String
    logNamespace Priority
    ERROR
          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 ()
    log (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 ()
    log (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

      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

          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 maybeBusName :: Maybe BusName
    maybeBusName = First BusName -> Maybe BusName
    forall a. First a -> Maybe a
    getFirst (First BusName -> Maybe BusName) -> First BusName -> Maybe BusName
    forall a b. (a -> b) -> a -> b
    $ [First BusName] -> First BusName
    forall a. Monoid a => [a] -> a
    mconcat ([First BusName] -> First BusName)
    -> [First BusName] -> First BusName
    forall a b. (a -> b) -> a -> b
    $
                               (Maybe BusName -> First BusName)
    -> [Maybe BusName] -> [First BusName]
    forall a b. (a -> b) -> [a] -> [b]
    map Maybe BusName -> First BusName
    forall a. Maybe a -> First a
    First [String -> Maybe BusName
    forall (m :: * -> *). MonadThrow m => String -> m BusName
    T.parseBusName String
    name, Maybe BusName
    sender]
                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
                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
            busName <- 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
    parseServiceError Maybe BusName
    maybeBusName
            let item = ItemEntry { serviceName :: BusName
    serviceName = BusName
    busName
                                 , servicePath :: ObjectPath
    servicePath = ObjectPath
    path
                                 }
            hasOwner <- ExceptT $ remapErrorName <$>
                        DBusTH.nameHasOwner client (coerce busName)
            lift $ modifyMVar_ notifierItems $ \[ItemEntry]
    currentItems ->
              if ItemEntry -> [ItemEntry] -> Bool
    forall {t :: * -> *} {a}. (Foldable t, Eq a) => a -> t a -> Bool
    itemIsRegistered ItemEntry
    item [ItemEntry]
    currentItems
              then
                [ItemEntry] -> IO [ItemEntry]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [ItemEntry]
    currentItems
              else
                do
                  Client -> String -> IO ()
    emitStatusNotifierItemRegistered Client
    client (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ BusName -> String
    forall a b. Coercible a b => a -> b
    coerce BusName
    busName
                  [ItemEntry] -> IO [ItemEntry]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([ItemEntry] -> IO [ItemEntry]) -> [ItemEntry] -> IO [ItemEntry]
    forall a b. (a -> b) -> a -> b
    $ ItemEntry
    item ItemEntry -> [ItemEntry] -> [ItemEntry]
    forall a. a -> [a] -> [a]
    : [ItemEntry]
    currentItems

          registerStatusNotifierHost String
    name =
            let item :: ItemEntry
    item = ItemEntry { serviceName :: BusName
    serviceName = String -> BusName
    busName_ String
    name
                                 , servicePath :: ObjectPath
    servicePath = ObjectPath
    "/StatusNotifierHost"
                                 } in
            MVar [ItemEntry] -> ([ItemEntry] -> IO [ItemEntry]) -> IO ()
    forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ MVar [ItemEntry]
    notifierHosts (([ItemEntry] -> IO [ItemEntry]) -> IO ())
    -> ([ItemEntry] -> IO [ItemEntry]) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \[ItemEntry]
    currentHosts ->
              if ItemEntry -> [ItemEntry] -> Bool
    forall {t :: * -> *} {a}. (Foldable t, Eq a) => a -> t a -> Bool
    itemIsRegistered ItemEntry
    item [ItemEntry]
    currentHosts
              then
                [ItemEntry] -> IO [ItemEntry]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [ItemEntry]
    currentHosts
              else
                do
                  Client -> IO ()
    emitStatusNotifierHostRegistered Client
    client
                  [ItemEntry] -> IO [ItemEntry]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([ItemEntry] -> IO [ItemEntry]) -> [ItemEntry] -> IO [ItemEntry]
    forall a b. (a -> b) -> a -> b
    $ ItemEntry
    item ItemEntry -> [ItemEntry] -> [ItemEntry]
    forall a. a -> [a] -> [a]
    : [ItemEntry]
    currentHosts

          registeredStatusNotifierItems :: IO [String]
          registeredStatusNotifierItems =
            (ItemEntry -> String) -> [ItemEntry] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (BusName -> String
    forall a b. Coercible a b => a -> b
    coerce (BusName -> String)
    -> (ItemEntry -> BusName) -> ItemEntry -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ItemEntry -> BusName
    serviceName) ([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 =
            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
    name) (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
                log $ printf "Unregistering item %s because it disappeared." name
                emitStatusNotifierItemUnregistered client name
              removedHosts <- filterDeadService name notifierHosts
              unless (null removedHosts) $
                log $ printf "Unregistering host %s because it disappeared." name
              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
                  export client (fromString path) watcherInterface
              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 }