Merge branch 'master' into v4

apps/simplex-chat/Main.hs

@@ -16,6 +16,7 @@ import Simplex.Input
 import Simplex.Messaging.Agent (getSMPAgentClient)
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Client (smpDefaultConfig)
+import Simplex.Notification
 import Simplex.Store (createStore)
 import Simplex.Terminal
 import System.Directory (getAppUserDataDirectory)
@@ -42,7 +43,8 @@ main = do
   void $ createStore "simplex-chat.db" 4
   ct <- newChatTerminal
   a <- getSMPAgentClient cfg {dbFile, smpServers}
-  cc <- atomically $ newChatController a ct $ tbqSize cfg
+  notify <- initializeNotifications
+  cc <- atomically $ newChatController a ct notify $ tbqSize cfg
   -- setLogLevel LogInfo -- LogError
   -- withGlobalLogging logCfg $ do
   runReaderT simplexChat cc

apps/simplex-chat/Simplex/Chat.hs

@@ -23,10 +23,11 @@ import Simplex.Help
 import Simplex.Messaging.Agent
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Parsers (parseAll)
+import Simplex.Messaging.Util (raceAny_)
+import Simplex.Notification
 import Simplex.Terminal
 import Simplex.View
 import Types
-import UnliftIO.Async (race_)
 import UnliftIO.STM
 
 data ChatCommand
@@ -39,7 +40,12 @@ data ChatCommand
   deriving (Show)
 
 runChatController :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
-runChatController = race_ inputSubscriber agentSubscriber
+runChatController =
+  raceAny_
+    [ inputSubscriber,
+      agentSubscriber,
+      notificationSubscriber
+    ]
 
 inputSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
 inputSubscriber = do
@@ -78,21 +84,30 @@ processChatCommand = \case
 agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
 agentSubscriber = do
   q <- asks $ subQ . smpAgent
+  nQ <- asks notifyQ
   forever $ do
     (_, a, resp) <- atomically (readTBQueue q)
+    let notify = \text -> atomically $ writeTBQueue nQ Notification {title = "@" <> a, text}
     case resp of
       CON -> do
         showContactConnected $ Contact a
         setActive' $ ActiveC $ Contact a
       END -> do
         showContactDisconnected $ Contact a
+        notify "disconnected"
         unsetActive' $ ActiveC $ Contact a
       MSG {brokerMeta, msgBody, msgIntegrity} -> do
         -- ReceivedMessage contact (snd brokerMeta) msgBody msgIntegrity
         showReceivedMessage (Contact a) (snd brokerMeta) msgBody msgIntegrity
+        notify msgBody
         setActive' $ ActiveC $ Contact a
       _ -> pure ()
 
+notificationSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
+notificationSubscriber = do
+  ChatController {notifyQ, sendNotification} <- ask
+  forever $ atomically (readTBQueue notifyQ) >>= liftIO . sendNotification
+
 withAgent :: ChatMonad m => Contact -> (AgentClient -> ExceptT AgentErrorType m a) -> m a
 withAgent c action =
   asks smpAgent

apps/simplex-chat/Simplex/Chat/Controller.hs

@@ -12,6 +12,7 @@ import Control.Monad.Reader
 import Numeric.Natural
 import Simplex.Messaging.Agent (AgentClient)
 import Simplex.Messaging.Agent.Protocol (AgentErrorType)
+import Simplex.Notification
 import Simplex.Terminal
 import Types
 import UnliftIO.STM
@@ -19,7 +20,9 @@ import UnliftIO.STM
 data ChatController = ChatController
   { smpAgent :: AgentClient,
     chatTerminal :: ChatTerminal,
-    inputQ :: TBQueue InputEvent
+    inputQ :: TBQueue InputEvent,
+    notifyQ :: TBQueue Notification,
+    sendNotification :: Notification -> IO ()
   }
 
 data InputEvent = InputCommand String | InputControl Char
@@ -29,10 +32,11 @@ data ChatError = ChatErrorAgent Contact AgentErrorType
 
 type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m)
 
-newChatController :: AgentClient -> ChatTerminal -> Natural -> STM ChatController
-newChatController smpAgent chatTerminal qSize = do
+newChatController :: AgentClient -> ChatTerminal -> (Notification -> IO ()) -> Natural -> STM ChatController
+newChatController smpAgent chatTerminal sendNotification qSize = do
   inputQ <- newTBQueue qSize
-  pure ChatController {smpAgent, chatTerminal, inputQ}
+  notifyQ <- newTBQueue qSize
+  pure ChatController {smpAgent, chatTerminal, inputQ, notifyQ, sendNotification}
 
 setActive' :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
 setActive' to = asks (activeTo . chatTerminal) >>= atomically . (`writeTVar` to)

apps/simplex-chat/Simplex/Notification.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Notification (Notification (..), initializeNotifications) where
+
+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 Simplex.Util (safeDecodeUtf8)
+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

apps/simplex-chat/Simplex/Util.hs

@@ -0,0 +1,10 @@
+module Simplex.Util where
+
+import Data.ByteString.Char8 (ByteString)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8With)
+
+safeDecodeUtf8 :: ByteString -> Text
+safeDecodeUtf8 = decodeUtf8With onError
+  where
+    onError _ _ = Just '?'

apps/simplex-chat/Simplex/View.hs

@@ -16,6 +16,7 @@ module Simplex.View
     ttyFromContact,
     ttyGroup,
     ttyFromGroup,
+    safeDecodeUtf8,
   )
 where
 
@@ -23,9 +24,7 @@ import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Data.ByteString.Char8 (ByteString)
 import Data.Composition ((.:))
-import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding (decodeUtf8With)
 import Data.Time.Clock (DiffTime, UTCTime)
 import Data.Time.Format (defaultTimeLocale, formatTime)
 import Data.Time.LocalTime (TimeZone, ZonedTime, getCurrentTimeZone, getZonedTime, localDay, localTimeOfDay, timeOfDayToTime, utcToLocalTime, zonedTimeToLocalTime)
@@ -34,6 +33,7 @@ import Simplex.Chat.Markdown
 import Simplex.Chat.Styled
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Terminal (printToTerminal)
+import Simplex.Util (safeDecodeUtf8)
 import System.Console.ANSI.Types
 import Types
 
@@ -144,8 +144,3 @@ ttyFromGroup (Group g) (Contact a) = styled (Colored Yellow) $ "#" <> g <> " " <
 
 styleTime :: String -> StyledString
 styleTime = Styled [SetColor Foreground Vivid Black]
-
-safeDecodeUtf8 :: ByteString -> Text
-safeDecodeUtf8 = decodeUtf8With onError
-  where
-    onError _ _ = Just '?'

package.yaml

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