{-# LANGUAGE UndecidableInstances #-}
module Navi.Env.DBus
( MonadDBus (..),
mkDBusEnv,
naviToDBus,
)
where
import DBus.Client (Client)
import DBus.Client qualified as DBus
import DBus.Notify (Hint (Urgency), Note)
import DBus.Notify qualified as DBusN
import Navi.Config (Config)
import Navi.Config.Types (NoteSystem (DBus))
import Navi.Data.NaviLog (LogEnv)
import Navi.Data.NaviNote (NaviNote, Timeout (Never, Seconds))
import Navi.Env.Core (Env (MkEnv, events, logEnv, noteQueue, notifySystem))
import Navi.Prelude
class (Monad m) => MonadDBus m where
connectSession :: (HasCallStack) => m Client
notify :: (HasCallStack) => Client -> NaviNote -> m ()
instance MonadDBus IO where
connectSession :: HasCallStack => IO Client
connectSession = IO Client
DBus.connectSession
notify :: HasCallStack => Client -> NaviNote -> IO ()
notify Client
client = IO Notification -> IO ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (IO Notification -> IO ())
-> (NaviNote -> IO Notification) -> NaviNote -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Client -> Note -> IO Notification
DBusN.notify Client
client (Note -> IO Notification)
-> (NaviNote -> Note) -> NaviNote -> IO Notification
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NaviNote -> Note
naviToDBus
instance (MonadDBus m) => MonadDBus (ReaderT env m) where
connectSession :: HasCallStack => ReaderT env m Client
connectSession = m Client -> ReaderT env m Client
forall (m :: Type -> Type) a. Monad m => m a -> ReaderT env m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Client
forall (m :: Type -> Type). (MonadDBus m, HasCallStack) => m Client
connectSession
notify :: HasCallStack => Client -> NaviNote -> ReaderT env m ()
notify Client
c = m () -> ReaderT env m ()
forall (m :: Type -> Type) a. Monad m => m a -> ReaderT env m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT env m ())
-> (NaviNote -> m ()) -> NaviNote -> ReaderT env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Client -> NaviNote -> m ()
forall (m :: Type -> Type).
(MonadDBus m, HasCallStack) =>
Client -> NaviNote -> m ()
notify Client
c
mkDBusEnv ::
(HasCallStack, MonadDBus m, MonadSTM m) =>
Maybe LogEnv ->
Config ->
m Env
mkDBusEnv :: forall (m :: Type -> Type).
(HasCallStack, MonadDBus m, MonadSTM m) =>
Maybe LogEnv -> Config -> m Env
mkDBusEnv Maybe LogEnv
logEnv Config
config = do
Client
client <- m Client
forall (m :: Type -> Type). (MonadDBus m, HasCallStack) => m Client
connectSession
TBQueue NaviNote
noteQueue <- Natural -> m (TBQueue NaviNote)
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM m) =>
Natural -> m (TBQueue a)
newTBQueueA Natural
1000
pure
$ MkEnv
{ events :: NonEmpty AnyEvent
events = Config
config Config
-> Optic' A_Lens NoIx Config (NonEmpty AnyEvent)
-> NonEmpty AnyEvent
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Config (NonEmpty AnyEvent)
#events,
Maybe LogEnv
logEnv :: Maybe LogEnv
logEnv :: Maybe LogEnv
logEnv,
TBQueue NaviNote
noteQueue :: TBQueue NaviNote
noteQueue :: TBQueue NaviNote
noteQueue,
notifySystem :: NoteSystem 'ConfigPhaseEnv
notifySystem = DBusF 'ConfigPhaseEnv -> NoteSystem 'ConfigPhaseEnv
forall (p :: ConfigPhase). DBusF p -> NoteSystem p
DBus Client
DBusF 'ConfigPhaseEnv
client
}
{-# INLINEABLE mkDBusEnv #-}
naviToDBus :: NaviNote -> Note
naviToDBus :: NaviNote -> Note
naviToDBus NaviNote
naviNote =
DBusN.Note
{ appName :: String
appName = String
"Navi",
summary :: String
summary = Text -> String
unpackText (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ NaviNote
naviNote NaviNote -> Optic' A_Lens NoIx NaviNote Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx NaviNote Text
#summary,
body :: Maybe Body
body = Maybe Body
body,
appImage :: Maybe Icon
appImage = Maybe Icon
forall a. Maybe a
Nothing,
hints :: [Hint]
hints = [Hint]
hints,
expiry :: Timeout
expiry = Timeout
timeout,
actions :: [(Action, String)]
actions = []
}
where
body :: Maybe Body
body = String -> Body
DBusN.Text (String -> Body) -> (Text -> String) -> Text -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
unpackText (Text -> Body) -> Maybe Text -> Maybe Body
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> NaviNote
naviNote NaviNote -> Optic' A_Lens NoIx NaviNote (Maybe Text) -> Maybe Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx NaviNote (Maybe Text)
#body
hints :: [Hint]
hints = Maybe Hint -> [Hint]
forall a. Maybe a -> [a]
maybeToList (Maybe Hint -> [Hint]) -> Maybe Hint -> [Hint]
forall a b. (a -> b) -> a -> b
$ UrgencyLevel -> Hint
Urgency (UrgencyLevel -> Hint) -> Maybe UrgencyLevel -> Maybe Hint
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> NaviNote
naviNote NaviNote
-> Optic' A_Lens NoIx NaviNote (Maybe UrgencyLevel)
-> Maybe UrgencyLevel
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx NaviNote (Maybe UrgencyLevel)
#urgency
timeout :: Timeout
timeout = Timeout -> (Timeout -> Timeout) -> Maybe Timeout -> Timeout
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Timeout
defTimeout Timeout -> Timeout
naviToDBusTimeout (Maybe Timeout -> Timeout) -> Maybe Timeout -> Timeout
forall a b. (a -> b) -> a -> b
$ NaviNote
naviNote NaviNote
-> Optic' A_Lens NoIx NaviNote (Maybe Timeout) -> Maybe Timeout
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx NaviNote (Maybe Timeout)
#timeout
defTimeout :: Timeout
defTimeout = Int32 -> Timeout
DBusN.Milliseconds Int32
10_000
naviToDBusTimeout :: Timeout -> DBusN.Timeout
naviToDBusTimeout :: Timeout -> Timeout
naviToDBusTimeout Timeout
Never = Timeout
DBusN.Never
naviToDBusTimeout (Seconds Word16
s) = Int32 -> Timeout
DBusN.Milliseconds (Int32 -> Timeout) -> Int32 -> Timeout
forall a b. (a -> b) -> a -> b
$ (Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
1_000) (Int32 -> Int32) -> Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ Word16 -> Int32
w16ToInt32 Word16
s
where
w16ToInt32 :: Word16 -> Int32
w16ToInt32 :: Word16 -> Int32
w16ToInt32 = Word16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral