{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Provides environment for usage with DBus.
module Navi.Env.DBus
  ( HasDBusClient (..),
    DBusEnv (..),
    mkDBusEnv,
    naviToDBus,
  )
where

import DBus.Client (Client)
import DBus.Notify (Hint (Urgency), Note)
import DBus.Notify qualified as DBusN
import Navi.Config (Config)
import Navi.Data.NaviLog (LogEnv)
import Navi.Data.NaviNote (NaviNote (..), Timeout (..))
import Navi.Env.Core
  ( Env (MkEnv),
    HasEvents (..),
    HasLogEnv (..),
    HasLogQueue (..),
    HasNoteQueue (..),
  )
import Navi.Prelude

-- | Retrieves the notification client.
class HasDBusClient env where
  getClient :: env -> Client

-- | Concrete dbus environment. Adds the dbus client.
data DBusEnv = MkDBusEnv
  { DBusEnv -> Env
coreEnv :: !Env,
    DBusEnv -> Client
dbusClient :: !Client
  }

makeFieldLabelsNoPrefix ''DBusEnv

instance HasEvents DBusEnv where
  getEvents :: DBusEnv -> NonEmpty AnyEvent
getEvents = forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (a :: OpticKind).
Is k A_Getter =>
Optic' k is s a -> s -> a
view (forall (a :: OpticKind). IsLabel "coreEnv" a => a
#coreEnv forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (a :: OpticKind). IsLabel "events" a => a
#events)
  {-# INLINEABLE getEvents #-}

instance HasLogEnv DBusEnv where
  getLogEnv :: DBusEnv -> LogEnv
getLogEnv = forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (a :: OpticKind).
Is k A_Getter =>
Optic' k is s a -> s -> a
view (forall (a :: OpticKind). IsLabel "coreEnv" a => a
#coreEnv forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (a :: OpticKind). IsLabel "logEnv" a => a
#logEnv)
  {-# INLINEABLE getLogEnv #-}
  localLogEnv :: (LogEnv -> LogEnv) -> DBusEnv -> DBusEnv
localLogEnv = forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (t :: OpticKind) (a :: OpticKind) (b :: OpticKind).
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over' (forall (a :: OpticKind). IsLabel "coreEnv" a => a
#coreEnv forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (a :: OpticKind). IsLabel "logEnv" a => a
#logEnv)
  {-# INLINEABLE localLogEnv #-}

instance HasLogQueue DBusEnv where
  getLogQueue :: DBusEnv -> TBQueue LogStr
getLogQueue = forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (a :: OpticKind).
Is k A_Getter =>
Optic' k is s a -> s -> a
view (forall (a :: OpticKind). IsLabel "coreEnv" a => a
#coreEnv forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (a :: OpticKind). IsLabel "logQueue" a => a
#logQueue)
  {-# INLINEABLE getLogQueue #-}

instance HasNoteQueue DBusEnv where
  getNoteQueue :: DBusEnv -> TBQueue NaviNote
getNoteQueue = forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (a :: OpticKind).
Is k A_Getter =>
Optic' k is s a -> s -> a
view (forall (a :: OpticKind). IsLabel "coreEnv" a => a
#coreEnv forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (a :: OpticKind). IsLabel "noteQueue" a => a
#noteQueue)
  {-# INLINEABLE getNoteQueue #-}

instance HasDBusClient DBusEnv where
  getClient :: DBusEnv -> Client
getClient = forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (a :: OpticKind).
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall (a :: OpticKind). IsLabel "dbusClient" a => a
#dbusClient
  {-# INLINEABLE getClient #-}

-- | Creates a 'DBusEnv' from the provided log types and configuration data.
mkDBusEnv ::
  (HasCallStack, MonadIO m, MonadSTM m) =>
  LogEnv ->
  Config ->
  m DBusEnv
mkDBusEnv :: forall (m :: OpticKind -> OpticKind).
(HasCallStack, MonadIO m, MonadSTM m) =>
LogEnv -> Config -> m DBusEnv
mkDBusEnv LogEnv
logEnv Config
config = do
  Client
client <- forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
MonadIO m =>
IO a -> m a
liftIO IO Client
DBusN.connectSession
  TBQueue LogStr
logQueue <- forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
(HasCallStack, MonadSTM m) =>
Natural -> m (TBQueue a)
newTBQueueM Natural
1000
  TBQueue NaviNote
noteQueue <- forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
(HasCallStack, MonadSTM m) =>
Natural -> m (TBQueue a)
newTBQueueM Natural
1000
  pure $
    MkDBusEnv
      { $sel:coreEnv:MkDBusEnv :: Env
coreEnv =
          NonEmpty AnyEvent
-> LogEnv -> TBQueue LogStr -> TBQueue NaviNote -> Env
MkEnv
            (Config
config forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "events" a => a
#events)
            LogEnv
logEnv
            TBQueue LogStr
logQueue
            TBQueue NaviNote
noteQueue,
        $sel:dbusClient:MkDBusEnv :: Client
dbusClient = Client
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
unpack forall (a :: OpticKind) b. (a -> b) -> a -> b
$ NaviNote
naviNote forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "summary" a => a
#summary,
      body :: Maybe Body
body = Maybe Body
body,
      appImage :: Maybe Icon
appImage = forall (a :: OpticKind). 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 forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> NaviNote
naviNote forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "body" a => a
#body
    hints :: [Hint]
hints = forall (a :: OpticKind). Maybe a -> [a]
maybeToList forall (a :: OpticKind) b. (a -> b) -> a -> b
$ UrgencyLevel -> Hint
Urgency forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> NaviNote
naviNote forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "urgency" a => a
#urgency
    timeout :: Timeout
timeout = forall (b :: OpticKind) (a :: OpticKind).
b -> (a -> b) -> Maybe a -> b
maybe Timeout
defTimeout Timeout -> Timeout
naviToDBusTimeout forall (a :: OpticKind) b. (a -> b) -> a -> b
$ NaviNote
naviNote forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "timeout" a => a
#timeout
    defTimeout :: Timeout
defTimeout = Int32 -> Timeout
DBusN.Milliseconds Int32
10_000
{-# INLINEABLE naviToDBus #-}

naviToDBusTimeout :: Timeout -> DBusN.Timeout
naviToDBusTimeout :: Timeout -> Timeout
naviToDBusTimeout Timeout
Never = Timeout
DBusN.Never
naviToDBusTimeout (Seconds Word16
s) = Int32 -> Timeout
DBusN.Milliseconds forall (a :: OpticKind) b. (a -> b) -> a -> b
$ (forall (a :: OpticKind). Num a => a -> a -> a
* Int32
1_000) forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Word16 -> Int32
w16ToInt32 Word16
s
  where
    w16ToInt32 :: Word16 -> Int32
    w16ToInt32 :: Word16 -> Int32
w16ToInt32 = forall (a :: OpticKind) (b :: OpticKind).
(Integral a, Num b) =>
a -> b
fromIntegral
{-# INLINEABLE naviToDBusTimeout #-}