diff --git a/apps/simplex-chat/Main.hs b/apps/simplex-chat/Main.hs index 858ee83faf..577edc9db7 100644 --- a/apps/simplex-chat/Main.hs +++ b/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 diff --git a/apps/simplex-chat/Simplex/Chat.hs b/apps/simplex-chat/Simplex/Chat.hs index 6abea5f858..57157e0d7d 100644 --- a/apps/simplex-chat/Simplex/Chat.hs +++ b/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 diff --git a/apps/simplex-chat/Simplex/Chat/Controller.hs b/apps/simplex-chat/Simplex/Chat/Controller.hs index 33801778a9..79e6f08f0b 100644 --- a/apps/simplex-chat/Simplex/Chat/Controller.hs +++ b/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) diff --git a/apps/simplex-chat/Simplex/Notification.hs b/apps/simplex-chat/Simplex/Notification.hs new file mode 100644 index 0000000000..7c1f3966a6 --- /dev/null +++ b/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 diff --git a/apps/simplex-chat/Simplex/Util.hs b/apps/simplex-chat/Simplex/Util.hs new file mode 100644 index 0000000000..29c7a1568c --- /dev/null +++ b/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 '?' diff --git a/apps/simplex-chat/Simplex/View.hs b/apps/simplex-chat/Simplex/View.hs index 7b431540cd..1e701c7bd8 100644 --- a/apps/simplex-chat/Simplex/View.hs +++ b/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 '?' diff --git a/package.yaml b/package.yaml index 1084dac95a..d27fa5f324 100644 --- a/package.yaml +++ b/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.*