{-# LANGUAGE UndecidableInstances #-}

-- | Provides environment for usage with DBus.
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
  -- | Connects to DBus.
  connectSession :: (HasCallStack) => m Client

  -- | Sends a notification to DBus.
  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

-- | Creates a 'DBusEnv' from the provided log types and configuration data.
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 #-}

-- | Turns a 'NaviNote' into a DBus 'Note'.
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