{-# 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 }