{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Effectful.Notify.Internal.System.DBus
  ( -- * Notifications
    initNotifyEnv,
    notify,

    -- * Re-exports

    -- ** Errors
    ClientError,
    Client.clientError,
    Client.clientErrorMessage,
    Client.clientErrorFatal,
  )
where

import Control.Exception
  ( Exception (toException),
    SomeException,
    catch,
    throwIO,
  )
import Control.Exception.Utils qualified as Ex.Utils
import Control.Monad (void)
import DBus.Client (Client, ClientError)
import DBus.Client qualified as Client
import DBus.Notify qualified as DBusN
import Data.Int (Int32)
import Data.Text qualified as T
import Effectful.Notify.Internal.Data.Note (Note)
import Effectful.Notify.Internal.Data.NotifyException
  ( NotifyException
      ( MkNotifyException,
        exception,
        fatal,
        note,
        notifySystem
      ),
  )
import Effectful.Notify.Internal.Data.NotifyInitException
  ( NotifyInitException (MkNotifyInitException),
  )
import Effectful.Notify.Internal.Data.NotifySystem
  ( NotifySystem (NotifySystemDBus),
  )
import Effectful.Notify.Internal.Data.NotifyTimeout
  ( NotifyTimeout (NotifyTimeoutMillis, NotifyTimeoutNever),
  )
import Effectful.Notify.Internal.Utils qualified as Utils
import GHC.Stack (HasCallStack)
import Optics.Core ((^.))

initNotifyEnv :: (HasCallStack) => IO Client
initNotifyEnv :: HasCallStack => IO Client
initNotifyEnv =
  IO Client
DBusN.connectSession
    IO Client -> (SomeException -> IO Client) -> IO Client
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`Ex.Utils.catchSync` (NotifyInitException -> IO Client
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (NotifyInitException -> IO Client)
-> (SomeException -> NotifyInitException)
-> SomeException
-> IO Client
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> NotifyInitException
MkNotifyInitException)

notify :: (HasCallStack) => Client -> Note -> IO ()
notify :: HasCallStack => Client -> Note -> IO ()
notify Client
client Note
note =
  Note -> IO ()
sendNote Note
note
    IO () -> (ClientError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \ClientError
ex ->
      -- According to the docs, toException drops the exception context,
      -- but we should be okay here since 'catch' annotates our new exception
      -- with the context (WhileHandling origEx), so the context should
      -- have the original stacktrace, while our NotifyInitException will
      -- wrap an contextless SomeException, which is fine.
      --
      -- Alternatively, we could use toExceptionWithBacktrace, but I think
      -- that would be redundant? It would be nice to check this.
      Bool -> SomeException -> IO ()
throwEx (ClientError -> Bool
Client.clientErrorFatal ClientError
ex) (ClientError -> SomeException
forall e. Exception e => e -> SomeException
toException ClientError
ex)
        IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`Ex.Utils.catchSync` \SomeException
someEx -> Bool -> SomeException -> IO ()
throwEx Bool
True SomeException
someEx
  where
    sendNote :: Note -> IO ()
sendNote = IO Notification -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Notification -> IO ())
-> (Note -> IO Notification) -> Note -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client -> Note -> IO Notification
DBusN.notify Client
client (Note -> IO Notification)
-> (Note -> Note) -> Note -> IO Notification
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Note
noteToDbus

    throwEx :: Bool -> SomeException -> IO ()
    throwEx :: Bool -> SomeException -> IO ()
throwEx Bool
fatal SomeException
ex =
      NotifyException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (NotifyException -> IO ()) -> NotifyException -> IO ()
forall a b. (a -> b) -> a -> b
$
        MkNotifyException
          { exception :: SomeException
exception = SomeException -> SomeException
forall e. Exception e => e -> SomeException
toException SomeException
ex,
            Bool
fatal :: Bool
fatal :: Bool
fatal,
            Note
note :: Note
note :: Note
note,
            notifySystem :: NotifySystem
notifySystem = NotifySystem
NotifySystemDBus
          }

noteToDbus :: Note -> DBusN.Note
noteToDbus :: Note -> Note
noteToDbus Note
note =
  DBusN.Note
    { appName :: String
DBusN.appName = String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Text -> String
T.unpack (Note
note Note -> Optic' A_Lens NoIx Note (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 Note (Maybe Text)
#title),
      body :: Maybe Body
DBusN.body = 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 -> Body) -> Maybe Text -> Maybe Body
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Note
note Note -> Optic' A_Lens NoIx Note (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 Note (Maybe Text)
#body,
      summary :: String
DBusN.summary = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Note
note Note -> Optic' A_Lens NoIx Note Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Note Text
#summary,
      appImage :: Maybe Icon
DBusN.appImage = Maybe Icon
forall a. Maybe a
Nothing,
      hints :: [Hint]
DBusN.hints = [],
      Timeout
expiry :: Timeout
expiry :: Timeout
DBusN.expiry,
      actions :: [(Action, String)]
DBusN.actions = []
    }
  where
    expiry :: Timeout
expiry = case Note
note Note
-> Optic' A_Lens NoIx Note (Maybe NotifyTimeout)
-> Maybe NotifyTimeout
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Note (Maybe NotifyTimeout)
#timeout of
      -- I think this is the default?
      Maybe NotifyTimeout
Nothing -> Timeout
DBusN.Dependent
      Just NotifyTimeout
NotifyTimeoutNever -> Timeout
DBusN.Never
      Just (NotifyTimeoutMillis Int
s) ->
        Int32 -> Timeout
DBusN.Milliseconds (forall a b.
(Bits a, Bits b, HasCallStack, Integral a, Integral b, Show a,
 Typeable a, Typeable b) =>
a -> b
Utils.unsafeConvertIntegral @Int @Int32 Int
s)