-- | Effect for NotifySend.
module Shrun.Notify.MonadNotifySend
  ( MonadNotifySend (..),
    notifyNotifySend,
  )
where

import DBus.Notify (UrgencyLevel (Critical, Low, Normal))
import Data.Text qualified as T
import Effects.Process.Typed qualified as P
import Shrun.Notify.MonadNotify
  ( NotifyException (MkNotifyException),
    ShrunNote,
    exitFailureToStderr,
  )
import Shrun.Notify.Types
  ( NotifySystemP (NotifySend),
    NotifyTimeout
      ( NotifyTimeoutNever,
        NotifyTimeoutSeconds
      ),
  )
import Shrun.Prelude
import Shrun.Utils qualified as Utils

-- | Effect for notify-send.
class (Monad m) => MonadNotifySend m where
  -- | Sends a notification via notify-send.
  notify :: (HasCallStack) => Text -> m (Maybe ByteString)

instance MonadNotifySend IO where
  notify :: HasCallStack => Text -> IO (Maybe ByteString)
notify =
    ((ExitCode, ByteString) -> Maybe ByteString)
-> IO (ExitCode, ByteString) -> IO (Maybe ByteString)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (ExitCode, ByteString) -> Maybe ByteString
exitFailureToStderr
      (IO (ExitCode, ByteString) -> IO (Maybe ByteString))
-> (Text -> IO (ExitCode, ByteString))
-> Text
-> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessConfig () () () -> IO (ExitCode, ByteString)
forall stdin stdout stderrIgnored.
HasCallStack =>
ProcessConfig stdin stdout stderrIgnored
-> IO (ExitCode, ByteString)
forall (m :: Type -> Type) stdin stdout stderrIgnored.
(MonadTypedProcess m, HasCallStack) =>
ProcessConfig stdin stdout stderrIgnored
-> m (ExitCode, ByteString)
P.readProcessStderr
      (ProcessConfig () () () -> IO (ExitCode, ByteString))
-> (Text -> ProcessConfig () () ())
-> Text
-> IO (ExitCode, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ProcessConfig () () ()
P.shell
      (String -> ProcessConfig () () ())
-> (Text -> String) -> Text -> ProcessConfig () () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

instance (MonadNotifySend m) => MonadNotifySend (ReaderT env m) where
  notify :: HasCallStack => Text -> ReaderT env m (Maybe ByteString)
notify = m (Maybe ByteString) -> ReaderT env m (Maybe ByteString)
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 ByteString) -> ReaderT env m (Maybe ByteString))
-> (Text -> m (Maybe ByteString))
-> Text
-> ReaderT env m (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m (Maybe ByteString)
forall (m :: Type -> Type).
(MonadNotifySend m, HasCallStack) =>
Text -> m (Maybe ByteString)
notify

notifyNotifySend ::
  ( HasCallStack,
    MonadNotifySend m
  ) =>
  ShrunNote ->
  m (Maybe NotifyException)
notifyNotifySend :: forall (m :: Type -> Type).
(HasCallStack, MonadNotifySend m) =>
ShrunNote -> m (Maybe NotifyException)
notifyNotifySend ShrunNote
note =
  Text -> m (Maybe ByteString)
forall (m :: Type -> Type).
(MonadNotifySend m, HasCallStack) =>
Text -> m (Maybe ByteString)
notify (ShrunNote -> Text
shrunToNotifySend ShrunNote
note) m (Maybe ByteString)
-> (ByteString -> 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)
<<&>> \ByteString
stderr ->
    ShrunNote -> NotifySystemMerged -> Text -> NotifyException
MkNotifyException ShrunNote
note NotifySystemMerged
forall (p :: ConfigPhase). NotifySystemP p
NotifySend (ByteString -> Text
decodeUtf8Lenient ByteString
stderr)

shrunToNotifySend :: ShrunNote -> Text
shrunToNotifySend :: ShrunNote -> Text
shrunToNotifySend ShrunNote
shrunNote = Text
txt
  where
    txt :: Text
txt =
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"notify-send ",
          Text
" --app-name Shrun \"",
          Text
summary,
          Text
"\" ",
          (\Text
b -> Text
" \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" ") Text
body,
          UrgencyLevel -> Text
forall {a}. IsString a => UrgencyLevel -> a
ulToNS (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),
          Text
timeout
        ]

    -- Encountered a bug where notify-send would error when given commands
    -- from the legend that contained quotes and --common-log-key-hide was active.
    -- This is presumably due to the command in the logs like
    --
    --     [Command][some cmd "with quotes"]...
    --
    -- which was then not properly escaped when sent off to notify-send.
    -- Technically the reproducer:
    --
    --     shrun --common-log-key-hide --notify-system notify-send --config=examples/config.toml ui
    --
    -- only required escaping the summary, but we do the same to the body out
    -- of paranoia.
    summary :: Text
summary = Text -> Text
Utils.escapeDoubleQuotes (Text -> Text) -> Text -> Text
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 :: Text
body = Text -> Text
Utils.escapeDoubleQuotes (Text -> Text) -> Text -> Text
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

    ulToNS :: UrgencyLevel -> a
ulToNS UrgencyLevel
Low = a
" --urgency low "
    ulToNS UrgencyLevel
Normal = a
" --urgency normal "
    ulToNS UrgencyLevel
Critical = a
" --urgency critical "

    timeout :: Text
timeout = 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 -> Text
" --expire-time 0 "
      NotifyTimeoutSeconds Word16
s ->
        [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
          [ Text
" --expire-time ",
            Integer -> Text
forall a. Show a => a -> Text
showt (forall a b.
(Bits a, Bits b, HasCallStack, Integral a, Integral b, Show a,
 Typeable a, Typeable b) =>
a -> b
unsafeConvertIntegral @_ @Integer Word16
s Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1_000)
          ]