-- | Effect for DBus.
module Shrun.Notify.MonadDBus
  ( MonadDBus (..),
    notifyDBus,
  )
where

import DBus.Client (Client)
import DBus.Client qualified as DBusC
import DBus.Notify (Hint (Urgency), Note)
import DBus.Notify qualified as DBusN
import Data.Text qualified as T
import Shrun.Notify.MonadNotify (NotifyException (MkNotifyException), ShrunNote)
import Shrun.Notify.Types
  ( NotifySystemP (DBus),
    NotifyTimeout
      ( NotifyTimeoutNever,
        NotifyTimeoutSeconds
      ),
  )
import Shrun.Prelude

-- | Effect for DBus.
class (Monad m) => MonadDBus m where
  -- | Connects to DBus.
  connectSession :: (HasCallStack) => m Client

  -- | Sends a notification to DBus.
  notify :: (HasCallStack) => Client -> Note -> m (Maybe SomeException)

instance MonadDBus IO where
  connectSession :: HasCallStack => IO Client
connectSession = IO Client
DBusC.connectSession
  notify :: HasCallStack => Client -> Note -> IO (Maybe SomeException)
notify Client
client Note
note =
    IO Notification -> IO (Either SomeException Notification)
forall (m :: Type -> Type) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
tryAny (Client -> Note -> IO Notification
DBusN.notify Client
client Note
note) IO (Either SomeException Notification)
-> (Either SomeException Notification -> Maybe SomeException)
-> IO (Maybe SomeException)
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      Left SomeException
err -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
err
      Right Notification
_ -> Maybe SomeException
forall a. Maybe a
Nothing

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 -> Note -> ReaderT env m (Maybe SomeException)
notify Client
c = m (Maybe SomeException) -> ReaderT env m (Maybe SomeException)
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 (Maybe SomeException) -> ReaderT env m (Maybe SomeException))
-> (Note -> m (Maybe SomeException))
-> Note
-> ReaderT env m (Maybe SomeException)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client -> Note -> m (Maybe SomeException)
forall (m :: Type -> Type).
(MonadDBus m, HasCallStack) =>
Client -> Note -> m (Maybe SomeException)
notify Client
c

notifyDBus ::
  ( HasCallStack,
    MonadDBus m
  ) =>
  Client ->
  ShrunNote ->
  m (Maybe NotifyException)
notifyDBus :: forall (m :: Type -> Type).
(HasCallStack, MonadDBus m) =>
Client -> ShrunNote -> m (Maybe NotifyException)
notifyDBus Client
client ShrunNote
note =
  Client -> Note -> m (Maybe SomeException)
forall (m :: Type -> Type).
(MonadDBus m, HasCallStack) =>
Client -> Note -> m (Maybe SomeException)
notify Client
client (ShrunNote -> Note
shrunToDBus ShrunNote
note) m (Maybe SomeException)
-> (SomeException -> NotifyException) -> m (Maybe NotifyException)
forall (f :: Type -> Type) (g :: Type -> Type) a b.
(Functor f, Functor g) =>
f (g a) -> (a -> b) -> f (g b)
<<&>> \SomeException
stderr ->
    ShrunNote -> NotifySystemMerged -> Text -> NotifyException
MkNotifyException ShrunNote
note (DBusF 'ConfigPhaseMerged -> NotifySystemMerged
forall (p :: ConfigPhase). DBusF p -> NotifySystemP p
DBus ()) (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
stderr)

shrunToDBus :: ShrunNote -> Note
shrunToDBus :: ShrunNote -> Note
shrunToDBus ShrunNote
shrunNote =
  DBusN.Note
    { appName :: String
appName = String
"Shrun",
      summary :: String
summary = Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ShrunNote
shrunNote ShrunNote -> Optic' A_Getter NoIx ShrunNote Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx ShrunNote ShrunNote UnlinedText UnlinedText
#summary Optic A_Lens NoIx ShrunNote ShrunNote UnlinedText UnlinedText
-> Optic A_Getter NoIx UnlinedText UnlinedText Text Text
-> Optic' A_Getter NoIx ShrunNote Text
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(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
% Optic A_Getter NoIx UnlinedText UnlinedText Text Text
#unUnlinedText,
      body :: Maybe Body
body = Body -> Maybe Body
forall a. a -> Maybe a
Just (Body -> Maybe Body) -> (Text -> Body) -> Text -> Maybe Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Body
DBusN.Text (String -> Body) -> (Text -> String) -> Text -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Maybe Body) -> Text -> Maybe Body
forall a b. (a -> b) -> a -> b
$ ShrunNote
shrunNote ShrunNote -> Optic' A_Getter NoIx ShrunNote Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx ShrunNote ShrunNote UnlinedText UnlinedText
#body Optic A_Lens NoIx ShrunNote ShrunNote UnlinedText UnlinedText
-> Optic A_Getter NoIx UnlinedText UnlinedText Text Text
-> Optic' A_Getter NoIx ShrunNote Text
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(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
% Optic A_Getter NoIx UnlinedText UnlinedText Text Text
#unUnlinedText,
      appImage :: Maybe Icon
appImage = Maybe Icon
forall a. Maybe a
Nothing,
      hints :: [Hint]
hints = [UrgencyLevel -> Hint
Urgency (ShrunNote
shrunNote ShrunNote
-> Optic' A_Lens NoIx ShrunNote UrgencyLevel -> UrgencyLevel
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ShrunNote UrgencyLevel
#urgency)],
      Timeout
expiry :: Timeout
expiry :: Timeout
expiry,
      actions :: [(Action, String)]
actions = []
    }
  where
    expiry :: Timeout
expiry = case ShrunNote
shrunNote ShrunNote
-> Optic' A_Lens NoIx ShrunNote NotifyTimeout -> NotifyTimeout
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ShrunNote NotifyTimeout
#timeout of
      NotifyTimeout
NotifyTimeoutNever -> Timeout
DBusN.Never
      NotifyTimeoutSeconds Word16
s ->
        Int32 -> Timeout
DBusN.Milliseconds (Int32 -> Timeout) -> Int32 -> Timeout
forall a b. (a -> b) -> a -> b
$ Int32
1_000 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Word16 -> Int32
forall a b.
(Bits a, Bits b, HasCallStack, Integral a, Integral b, Show a,
 Typeable a, Typeable b) =>
a -> b
unsafeConvertIntegral Word16
s