desktop notifications (#64)

* send notifications

* support for linux notifications (draft)

* add support for linux, win (draft) and wsl (draft) notifications

* add support for windows/wsl notifications

* add unix to extra-deps

* add alternative linux notification method

* remove unused cpp conditions

* fix notification commands for win/lin

* remove dbus package and code

* remove fdo-notify from extra-deps

* move script running logic to common method + add lacking quotes

* remove unrelated workspace file

* corrections

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>

apps/dog-food/Main.hs

@@ -27,6 +27,7 @@ import Data.Text.Encoding
 import Data.Time.Clock (DiffTime, UTCTime)
 import Data.Time.Format (defaultTimeLocale, formatTime)
 import Data.Time.LocalTime
+import Notification
 import Numeric.Natural
 import Simplex.Chat.Markdown
 import Simplex.Messaging.Agent (getSMPAgentClient, runSMPAgentClient)
@@ -58,7 +59,9 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 
 data ChatClient = ChatClient
   { inQ :: TBQueue ChatCommand,
-    outQ :: TBQueue ChatResponse
+    outQ :: TBQueue ChatResponse,
+    notifyQ :: TBQueue Notification,
+    displayNotification :: Notification -> IO ()
   }
 
 -- | GroupMessage ChatGroup ByteString
@@ -227,7 +230,7 @@ markdownInfo =
 main :: IO ()
 main = do
   opts@ChatOpts {dbFile, smpServers, termMode} <- welcomeGetOpts
-  t <- atomically $ newChatClient (tbqSize cfg)
+  t <- newChatClient (tbqSize cfg)
   ct <- newChatTerminal (tbqSize cfg) termMode
   -- setLogLevel LogInfo -- LogError
   -- withGlobalLogging logCfg $ do
@@ -253,14 +256,17 @@ dogFoodChat t ct env opts = do
       sendToChatTerm t ct opts localTz,
       receiveFromAgent t ct c,
       receiveFromChatTerm t ct,
+      showNotifications t,
       chatTerminal ct
     ]
 
-newChatClient :: Natural -> STM ChatClient
+newChatClient :: Natural -> IO ChatClient
 newChatClient qSize = do
-  inQ <- newTBQueue qSize
-  outQ <- newTBQueue qSize
-  return ChatClient {inQ, outQ}
+  inQ <- newTBQueueIO qSize
+  outQ <- newTBQueueIO qSize
+  notifyQ <- newTBQueueIO qSize
+  displayNotification <- initializeNotifications
+  return ChatClient {inQ, outQ, notifyQ, displayNotification}
 
 receiveFromChatTerm :: ChatClient -> ChatTerminal -> IO ()
 receiveFromChatTerm t ct = forever $ do
@@ -321,6 +327,7 @@ receiveFromAgent t ct c = forever . atomically $ do
   resp <- chatResponse <$> readTBQueue (sndQ c)
   writeTBQueue (outQ t) resp
   setActiveTo resp
+  sendNotification resp
   where
     chatResponse :: ATransmission 'Agent -> ChatResponse
     chatResponse (ATransmission _ entity resp) = case entity of
@@ -358,6 +365,17 @@ receiveFromAgent t ct c = forever . atomically $ do
       ReceivedGroupMessage g _ _ _ _ -> setActive ct $ ActiveG g
       Disconnected a -> unsetActive ct $ ActiveC a
       _ -> pure ()
+    sendNotification :: ChatResponse -> STM ()
+    sendNotification = \case
+      ReceivedMessage c' _ msg _ -> notify $ Notification ("@" <> toBs c') msg
+      ReceivedGroupMessage g c' _ msg _ -> notify $ Notification ("#" <> fromGroup g <> " @" <> toBs c') msg
+      Disconnected c' -> notify $ Notification ("@" <> toBs c') "disconnected"
+      _ -> pure ()
+    notify :: Notification -> STM ()
+    notify n = writeTBQueue (notifyQ t) n
+
+showNotifications :: ChatClient -> IO ()
+showNotifications t = forever $ atomically (readTBQueue $ notifyQ t) >>= displayNotification t
 
 groupMessageP :: Parser (Group, ByteString)
 groupMessageP =

apps/dog-food/Notification.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Notification (Notification (..), initializeNotifications) where
+
+import ChatTerminal.Core (safeDecodeUtf8)
+import Control.Monad (void)
+import Data.ByteString.Char8 (ByteString)
+import Data.Char (toLower)
+import Data.List (isInfixOf)
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.Directory (doesFileExist, getAppUserDataDirectory)
+import System.FilePath (combine)
+import System.Info (os)
+import System.Process (readCreateProcess, shell)
+
+data Notification = Notification {title :: ByteString, text :: ByteString}
+
+initializeNotifications :: IO (Notification -> IO ())
+initializeNotifications = case os of
+  "darwin" -> pure $ notify macScript
+  "mingw32" -> initWinNotify
+  "linux" ->
+    doesFileExist "/proc/sys/kernel/osrelease" >>= \case
+      False -> pure $ notify linuxScript
+      True -> do
+        v <- readFile "/proc/sys/kernel/osrelease"
+        if "wsl" `isInfixOf` map toLower v
+          then initWinNotify
+          else pure $ notify linuxScript
+  _ -> pure . const $ pure ()
+
+notify :: (Notification -> Text) -> Notification -> IO ()
+notify script notification =
+  void $ readCreateProcess (shell . T.unpack $ script notification) ""
+
+linuxScript :: Notification -> Text
+linuxScript Notification {title, text} = "notify-send \"" <> safeDecodeUtf8 title <> "\" \"" <> safeDecodeUtf8 text <> "\""
+
+macScript :: Notification -> Text
+macScript Notification {title, text} = "osascript -e 'display notification \"" <> safeDecodeUtf8 text <> "\" with title \"" <> safeDecodeUtf8 title <> "\"'"
+
+initWinNotify :: IO (Notification -> IO ())
+initWinNotify = notify . winScript <$> savePowershellScript
+
+winScript :: FilePath -> Notification -> Text
+winScript path Notification {title, text} = "powershell.exe \"" <> T.pack path <> " \'" <> safeDecodeUtf8 title <> "\' \'" <> safeDecodeUtf8 text <> "\'\""
+
+savePowershellScript :: IO FilePath
+savePowershellScript = do
+  appDir <- getAppUserDataDirectory "simplex"
+  let psScript = combine appDir "win-toast-notify.ps1"
+  writeFile
+    psScript
+    "[Windows.UI.Notifications.ToastNotificationManager, Windows.UI.Notifications, ContentType = WindowsRuntime] > $null\n\
+    \$Template = [Windows.UI.Notifications.ToastNotificationManager]::GetTemplateContent([Windows.UI.Notifications.ToastTemplateType]::ToastText02)\n\
+    \$RawXml = [xml] $Template.GetXml()\n\
+    \($RawXml.toast.visual.binding.text|where {$_.id -eq \"1\"}).AppendChild($RawXml.CreateTextNode($args[0])) > $null\n\
+    \($RawXml.toast.visual.binding.text|where {$_.id -eq \"2\"}).AppendChild($RawXml.CreateTextNode($args[1])) > $null\n\
+    \$SerializedXml = New-Object Windows.Data.Xml.Dom.XmlDocument\n\
+    \$SerializedXml.LoadXml($RawXml.OuterXml)\n\
+    \$Toast = [Windows.UI.Notifications.ToastNotification]::new($SerializedXml)\n\
+    \$Toast.Tag = \"simplex-chat\"\n\
+    \$Toast.Group = \"simplex-chat\"\n\
+    \$Toast.ExpirationTime = [DateTimeOffset]::Now.AddMinutes(1)\n\
+    \$Notifier = [Windows.UI.Notifications.ToastNotificationManager]::CreateToastNotifier(\"PowerShell\")\n\
+    \$Notifier.Show($Toast);\n"
+  return psScript

package.yaml

@@ -33,6 +33,7 @@ executables:
       - filepath == 1.4.*
       - mtl == 2.2.*
       - optparse-applicative == 0.15.*
+      - process == 1.6.*
       - simple-logger == 0.1.*
       - simplexmq == 0.3.*
       - stm == 2.5.*