mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-06-28 20:29:53 +00:00
core: use fourmolu styles (#3470)
This commit is contained in:
parent
75c2de8a12
commit
d29f1bb0cf
43 changed files with 902 additions and 865 deletions
30
fourmolu.yaml
Normal file
30
fourmolu.yaml
Normal file
|
@ -0,0 +1,30 @@
|
||||||
|
indentation: 2
|
||||||
|
column-limit: none
|
||||||
|
function-arrows: trailing
|
||||||
|
comma-style: trailing
|
||||||
|
import-export-style: trailing
|
||||||
|
indent-wheres: true
|
||||||
|
record-brace-space: true
|
||||||
|
newlines-between-decls: 1
|
||||||
|
haddock-style: single-line
|
||||||
|
haddock-style-module: null
|
||||||
|
let-style: inline
|
||||||
|
in-style: right-align
|
||||||
|
single-constraint-parens: never
|
||||||
|
unicode: never
|
||||||
|
respectful: true
|
||||||
|
fixities:
|
||||||
|
- infixr 9 .
|
||||||
|
- infixr 8 .:, .:., .=
|
||||||
|
- infixr 6 <>
|
||||||
|
- infixr 5 ++
|
||||||
|
- infixl 4 <$>, <$, $>, <$$>, <$?>
|
||||||
|
- infixl 4 <*>, <*, *>, <**>
|
||||||
|
- infix 4 ==, /=
|
||||||
|
- infixr 3 &&
|
||||||
|
- infixl 3 <|>
|
||||||
|
- infixr 2 ||
|
||||||
|
- infixl 1 >>, >>=
|
||||||
|
- infixr 1 =<<, >=>, <=<
|
||||||
|
- infixr 0 $, $!
|
||||||
|
reexports: []
|
File diff suppressed because one or more lines are too long
|
@ -22,7 +22,7 @@ import qualified Data.Text as T
|
||||||
import qualified Database.SQLite3 as SQL
|
import qualified Database.SQLite3 as SQL
|
||||||
import Simplex.Chat.Controller
|
import Simplex.Chat.Controller
|
||||||
import Simplex.Messaging.Agent.Client (agentClientStore)
|
import Simplex.Messaging.Agent.Client (agentClientStore)
|
||||||
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), sqlString, closeSQLiteStore)
|
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), closeSQLiteStore, sqlString)
|
||||||
import Simplex.Messaging.Util
|
import Simplex.Messaging.Util
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import UnliftIO.Directory
|
import UnliftIO.Directory
|
||||||
|
|
|
@ -6,8 +6,8 @@ module Simplex.Chat.Bot.KnownContacts where
|
||||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||||
import Data.Int (Int64)
|
import Data.Int (Int64)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text.Encoding (encodeUtf8)
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
import Data.Text.Encoding (encodeUtf8)
|
||||||
import Options.Applicative
|
import Options.Applicative
|
||||||
import Simplex.Messaging.Parsers (parseAll)
|
import Simplex.Messaging.Parsers (parseAll)
|
||||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||||
|
|
|
@ -225,4 +225,3 @@ instance FromField CallState where
|
||||||
fromField = fromTextField_ decodeJSON
|
fromField = fromTextField_ decodeJSON
|
||||||
|
|
||||||
$(J.deriveJSON defaultJSON ''RcvCallInvitation)
|
$(J.deriveJSON defaultJSON ''RcvCallInvitation)
|
||||||
|
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
@ -426,19 +426,19 @@ data ChatCommand
|
||||||
| SetGroupTimedMessages GroupName (Maybe Int)
|
| SetGroupTimedMessages GroupName (Maybe Int)
|
||||||
| SetLocalDeviceName Text
|
| SetLocalDeviceName Text
|
||||||
| ListRemoteHosts
|
| ListRemoteHosts
|
||||||
| StartRemoteHost (Maybe (RemoteHostId, Bool)) -- ^ Start new or known remote host with optional multicast for known host
|
| StartRemoteHost (Maybe (RemoteHostId, Bool)) -- Start new or known remote host with optional multicast for known host
|
||||||
| SwitchRemoteHost (Maybe RemoteHostId) -- ^ Switch current remote host
|
| SwitchRemoteHost (Maybe RemoteHostId) -- Switch current remote host
|
||||||
| StopRemoteHost RHKey -- ^ Shut down a running session
|
| StopRemoteHost RHKey -- Shut down a running session
|
||||||
| DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data
|
| DeleteRemoteHost RemoteHostId -- Unregister remote host and remove its data
|
||||||
| StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath}
|
| StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath}
|
||||||
| GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile}
|
| GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile}
|
||||||
| ConnectRemoteCtrl RCSignedInvitation -- ^ Connect new or existing controller via OOB data
|
| ConnectRemoteCtrl RCSignedInvitation -- Connect new or existing controller via OOB data
|
||||||
| FindKnownRemoteCtrl -- ^ Start listening for announcements from all existing controllers
|
| FindKnownRemoteCtrl -- Start listening for announcements from all existing controllers
|
||||||
| ConfirmRemoteCtrl RemoteCtrlId -- ^ Confirm the connection with found controller
|
| ConfirmRemoteCtrl RemoteCtrlId -- Confirm the connection with found controller
|
||||||
| VerifyRemoteCtrlSession Text -- ^ Verify remote controller session
|
| VerifyRemoteCtrlSession Text -- Verify remote controller session
|
||||||
| ListRemoteCtrls
|
| ListRemoteCtrls
|
||||||
| StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session
|
| StopRemoteCtrl -- Stop listening for announcements or terminate an active session
|
||||||
| DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a remote controller session
|
| DeleteRemoteCtrl RemoteCtrlId -- Remove all local data associated with a remote controller session
|
||||||
| QuitChat
|
| QuitChat
|
||||||
| ShowVersion
|
| ShowVersion
|
||||||
| DebugLocks
|
| DebugLocks
|
||||||
|
@ -1072,13 +1072,13 @@ throwDBError = throwError . ChatErrorDatabase
|
||||||
|
|
||||||
-- TODO review errors, some of it can be covered by HTTP2 errors
|
-- TODO review errors, some of it can be covered by HTTP2 errors
|
||||||
data RemoteHostError
|
data RemoteHostError
|
||||||
= RHEMissing -- ^ No remote session matches this identifier
|
= RHEMissing -- No remote session matches this identifier
|
||||||
| RHEInactive -- ^ A session exists, but not active
|
| RHEInactive -- A session exists, but not active
|
||||||
| RHEBusy -- ^ A session is already running
|
| RHEBusy -- A session is already running
|
||||||
| RHETimeout
|
| RHETimeout
|
||||||
| RHEBadState -- ^ Illegal state transition
|
| RHEBadState -- Illegal state transition
|
||||||
| RHEBadVersion {appVersion :: AppVersion}
|
| RHEBadVersion {appVersion :: AppVersion}
|
||||||
| RHELocalCommand -- ^ Command not allowed for remote execution
|
| RHELocalCommand -- Command not allowed for remote execution
|
||||||
| RHEDisconnected {reason :: Text} -- TODO should be sent when disconnected?
|
| RHEDisconnected {reason :: Text} -- TODO should be sent when disconnected?
|
||||||
| RHEProtocolError RemoteProtocolError
|
| RHEProtocolError RemoteProtocolError
|
||||||
deriving (Show, Exception)
|
deriving (Show, Exception)
|
||||||
|
@ -1091,13 +1091,14 @@ data RemoteHostStopReason
|
||||||
|
|
||||||
-- TODO review errors, some of it can be covered by HTTP2 errors
|
-- TODO review errors, some of it can be covered by HTTP2 errors
|
||||||
data RemoteCtrlError
|
data RemoteCtrlError
|
||||||
= RCEInactive -- ^ No session is running
|
= RCEInactive -- No session is running
|
||||||
| RCEBadState -- ^ A session is in a wrong state for the current operation
|
| RCEBadState -- A session is in a wrong state for the current operation
|
||||||
| RCEBusy -- ^ A session is already running
|
| RCEBusy -- A session is already running
|
||||||
| RCETimeout
|
| RCETimeout
|
||||||
| RCENoKnownControllers -- ^ No previously-contacted controllers to discover
|
| RCENoKnownControllers -- No previously-contacted controllers to discover
|
||||||
| RCEBadController -- ^ Attempting to confirm a found controller with another ID
|
| RCEBadController -- Attempting to confirm a found controller with another ID
|
||||||
| RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected by a controller
|
| -- | A session disconnected by a controller
|
||||||
|
RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text}
|
||||||
| RCEBadInvitation
|
| RCEBadInvitation
|
||||||
| RCEBadVersion {appVersion :: AppVersion}
|
| RCEBadVersion {appVersion :: AppVersion}
|
||||||
| RCEHTTP2Error {http2Error :: Text} -- TODO currently not used
|
| RCEHTTP2Error {http2Error :: Text} -- TODO currently not used
|
||||||
|
@ -1223,8 +1224,8 @@ toView event = do
|
||||||
session <- asks remoteCtrlSession
|
session <- asks remoteCtrlSession
|
||||||
atomically $
|
atomically $
|
||||||
readTVar session >>= \case
|
readTVar session >>= \case
|
||||||
Just (_, RCSessionConnected {remoteOutputQ}) | allowRemoteEvent event ->
|
Just (_, RCSessionConnected {remoteOutputQ})
|
||||||
writeTBQueue remoteOutputQ event
|
| allowRemoteEvent event -> writeTBQueue remoteOutputQ event
|
||||||
-- TODO potentially, it should hold some events while connecting
|
-- TODO potentially, it should hold some events while connecting
|
||||||
_ -> writeTBQueue localQ (Nothing, Nothing, event)
|
_ -> writeTBQueue localQ (Nothing, Nothing, event)
|
||||||
|
|
||||||
|
|
|
@ -6,8 +6,8 @@ module Simplex.Chat.Files where
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Simplex.Chat.Controller
|
import Simplex.Chat.Controller
|
||||||
import Simplex.Messaging.Util (ifM)
|
import Simplex.Messaging.Util (ifM)
|
||||||
import System.FilePath (splitExtensions, combine)
|
import System.FilePath (combine, splitExtensions)
|
||||||
import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, getHomeDirectory, doesDirectoryExist)
|
import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getHomeDirectory, getTemporaryDirectory)
|
||||||
|
|
||||||
uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
|
uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
|
||||||
uniqueCombine fPath fName = tryCombine (0 :: Int)
|
uniqueCombine fPath fName = tryCombine (0 :: Int)
|
||||||
|
|
|
@ -19,7 +19,7 @@ import qualified Data.Attoparsec.Text as A
|
||||||
import Data.Char (isDigit, isPunctuation)
|
import Data.Char (isDigit, isPunctuation)
|
||||||
import Data.Either (fromRight)
|
import Data.Either (fromRight)
|
||||||
import Data.Functor (($>))
|
import Data.Functor (($>))
|
||||||
import Data.List (intercalate, foldl')
|
import Data.List (foldl', intercalate)
|
||||||
import Data.List.NonEmpty (NonEmpty)
|
import Data.List.NonEmpty (NonEmpty)
|
||||||
import qualified Data.List.NonEmpty as L
|
import qualified Data.List.NonEmpty as L
|
||||||
import Data.Maybe (fromMaybe, isNothing)
|
import Data.Maybe (fromMaybe, isNothing)
|
||||||
|
@ -85,7 +85,9 @@ newtype FormatColor = FormatColor Color
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
instance FromJSON FormatColor where
|
instance FromJSON FormatColor where
|
||||||
parseJSON = J.withText "FormatColor" $ fmap FormatColor . \case
|
parseJSON =
|
||||||
|
J.withText "FormatColor" $
|
||||||
|
fmap FormatColor . \case
|
||||||
"red" -> pure Red
|
"red" -> pure Red
|
||||||
"green" -> pure Green
|
"green" -> pure Green
|
||||||
"blue" -> pure Blue
|
"blue" -> pure Blue
|
||||||
|
|
|
@ -11,7 +11,6 @@
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||||
|
|
||||||
module Simplex.Chat.Messages where
|
module Simplex.Chat.Messages where
|
||||||
|
@ -44,7 +43,7 @@ import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptSta
|
||||||
import Simplex.Messaging.Crypto.File (CryptoFile (..))
|
import Simplex.Messaging.Crypto.File (CryptoFile (..))
|
||||||
import qualified Simplex.Messaging.Crypto.File as CF
|
import qualified Simplex.Messaging.Crypto.File as CF
|
||||||
import Simplex.Messaging.Encoding.String
|
import Simplex.Messaging.Encoding.String
|
||||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, parseAll, enumJSON, sumTypeJSON)
|
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, parseAll, sumTypeJSON)
|
||||||
import Simplex.Messaging.Protocol (MsgBody)
|
import Simplex.Messaging.Protocol (MsgBody)
|
||||||
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
|
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
|
||||||
|
|
||||||
|
|
|
@ -311,7 +311,7 @@ profileToText Profile {displayName, fullName} = displayName <> optionalFullName
|
||||||
msgIntegrityError :: MsgErrorType -> Text
|
msgIntegrityError :: MsgErrorType -> Text
|
||||||
msgIntegrityError = \case
|
msgIntegrityError = \case
|
||||||
MsgSkipped fromId toId ->
|
MsgSkipped fromId toId ->
|
||||||
"skipped message ID " <> tshow fromId
|
("skipped message ID " <> tshow fromId)
|
||||||
<> if fromId == toId then "" else ".." <> tshow toId
|
<> if fromId == toId then "" else ".." <> tshow toId
|
||||||
MsgBadId msgId -> "unexpected message ID " <> tshow msgId
|
MsgBadId msgId -> "unexpected message ID " <> tshow msgId
|
||||||
MsgBadHash -> "incorrect message hash"
|
MsgBadHash -> "incorrect message hash"
|
||||||
|
|
|
@ -46,8 +46,8 @@ data SndConnEvent
|
||||||
| SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef}
|
| SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
data RcvDirectEvent =
|
data RcvDirectEvent
|
||||||
-- RDEProfileChanged {...}
|
= -- RDEProfileChanged {...}
|
||||||
RDEContactDeleted
|
RDEContactDeleted
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
|
|
|
@ -4,13 +4,12 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fobject-code #-}
|
{-# OPTIONS_GHC -fobject-code #-}
|
||||||
|
|
||||||
module Simplex.Chat.Mobile where
|
module Simplex.Chat.Mobile where
|
||||||
|
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Exception (catch, SomeException)
|
import Control.Exception (SomeException, catch)
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import qualified Data.Aeson as J
|
import qualified Data.Aeson as J
|
||||||
|
@ -31,7 +30,7 @@ import Foreign.C.Types (CInt (..))
|
||||||
import Foreign.Ptr
|
import Foreign.Ptr
|
||||||
import Foreign.StablePtr
|
import Foreign.StablePtr
|
||||||
import Foreign.Storable (poke)
|
import Foreign.Storable (poke)
|
||||||
import GHC.IO.Encoding (setLocaleEncoding, setFileSystemEncoding, setForeignEncoding)
|
import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding)
|
||||||
import Simplex.Chat
|
import Simplex.Chat
|
||||||
import Simplex.Chat.Controller
|
import Simplex.Chat.Controller
|
||||||
import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
|
import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
|
||||||
|
|
|
@ -6,8 +6,8 @@ import qualified Data.ByteString as B
|
||||||
import Data.ByteString.Internal (ByteString (..), memcpy)
|
import Data.ByteString.Internal (ByteString (..), memcpy)
|
||||||
import qualified Data.ByteString.Lazy as LB
|
import qualified Data.ByteString.Lazy as LB
|
||||||
import qualified Data.ByteString.Lazy.Internal as LB
|
import qualified Data.ByteString.Lazy.Internal as LB
|
||||||
import Foreign.C (CInt, CString)
|
|
||||||
import Foreign
|
import Foreign
|
||||||
|
import Foreign.C (CInt, CString)
|
||||||
|
|
||||||
type CJSONString = CString
|
type CJSONString = CString
|
||||||
|
|
||||||
|
|
|
@ -1,12 +1,12 @@
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
|
||||||
module Simplex.Chat.Mobile.WebRTC (
|
module Simplex.Chat.Mobile.WebRTC
|
||||||
cChatEncryptMedia,
|
( cChatEncryptMedia,
|
||||||
cChatDecryptMedia,
|
cChatDecryptMedia,
|
||||||
chatEncryptMedia,
|
chatEncryptMedia,
|
||||||
chatDecryptMedia,
|
chatDecryptMedia,
|
||||||
reservedSize,
|
reservedSize,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
|
@ -21,8 +21,8 @@ import Data.Either (fromLeft)
|
||||||
import Data.Word (Word8)
|
import Data.Word (Word8)
|
||||||
import Foreign.C (CInt, CString, newCAString)
|
import Foreign.C (CInt, CString, newCAString)
|
||||||
import Foreign.Ptr (Ptr)
|
import Foreign.Ptr (Ptr)
|
||||||
import qualified Simplex.Messaging.Crypto as C
|
|
||||||
import Simplex.Chat.Mobile.Shared
|
import Simplex.Chat.Mobile.Shared
|
||||||
|
import qualified Simplex.Messaging.Crypto as C
|
||||||
|
|
||||||
cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
|
cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
|
||||||
cChatEncryptMedia = cTransformMedia chatEncryptMedia
|
cChatEncryptMedia = cTransformMedia chatEncryptMedia
|
||||||
|
|
|
@ -13,7 +13,6 @@
|
||||||
{-# LANGUAGE StrictData #-}
|
{-# LANGUAGE StrictData #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||||
|
|
||||||
module Simplex.Chat.Protocol where
|
module Simplex.Chat.Protocol where
|
||||||
|
|
|
@ -97,7 +97,8 @@ discoveryTimeout = 60000000
|
||||||
getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient
|
getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient
|
||||||
getRemoteHostClient rhId = do
|
getRemoteHostClient rhId = do
|
||||||
sessions <- asks remoteHostSessions
|
sessions <- asks remoteHostSessions
|
||||||
liftIOEither . atomically $ TM.lookup rhKey sessions >>= \case
|
liftIOEither . atomically $
|
||||||
|
TM.lookup rhKey sessions >>= \case
|
||||||
Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient
|
Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient
|
||||||
Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
|
Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
|
||||||
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
|
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
|
||||||
|
@ -107,7 +108,8 @@ getRemoteHostClient rhId = do
|
||||||
withRemoteHostSession :: ChatMonad m => RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> m a
|
withRemoteHostSession :: ChatMonad m => RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> m a
|
||||||
withRemoteHostSession rhKey sseq f = do
|
withRemoteHostSession rhKey sseq f = do
|
||||||
sessions <- asks remoteHostSessions
|
sessions <- asks remoteHostSessions
|
||||||
r <- atomically $
|
r <-
|
||||||
|
atomically $
|
||||||
TM.lookup rhKey sessions >>= \case
|
TM.lookup rhKey sessions >>= \case
|
||||||
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
|
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
|
||||||
Just (stateSeq, state)
|
Just (stateSeq, state)
|
||||||
|
@ -167,12 +169,14 @@ startRemoteHost rh_ = do
|
||||||
when (encoding == PEKotlin && localEncoding == PESwift) $ throwError $ RHEProtocolError RPEIncompatibleEncoding
|
when (encoding == PEKotlin && localEncoding == PESwift) $ throwError $ RHEProtocolError RPEIncompatibleEncoding
|
||||||
pure hostInfo
|
pure hostInfo
|
||||||
handleConnectError :: ChatMonad m => RHKey -> SessionSeq -> m a -> m a
|
handleConnectError :: ChatMonad m => RHKey -> SessionSeq -> m a -> m a
|
||||||
handleConnectError rhKey sessSeq action = action `catchChatError` \err -> do
|
handleConnectError rhKey sessSeq action =
|
||||||
|
action `catchChatError` \err -> do
|
||||||
logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err
|
logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err
|
||||||
cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey
|
cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey
|
||||||
throwError err
|
throwError err
|
||||||
handleHostError :: ChatMonad m => SessionSeq -> TVar RHKey -> m () -> m ()
|
handleHostError :: ChatMonad m => SessionSeq -> TVar RHKey -> m () -> m ()
|
||||||
handleHostError sessSeq rhKeyVar action = action `catchChatError` \err -> do
|
handleHostError sessSeq rhKeyVar action =
|
||||||
|
action `catchChatError` \err -> do
|
||||||
logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err
|
logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err
|
||||||
readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err))
|
readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err))
|
||||||
waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m ()
|
waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m ()
|
||||||
|
@ -250,7 +254,8 @@ cancelRemoteHostSession :: ChatMonad m => Maybe (SessionSeq, RemoteHostStopReaso
|
||||||
cancelRemoteHostSession handlerInfo_ rhKey = do
|
cancelRemoteHostSession handlerInfo_ rhKey = do
|
||||||
sessions <- asks remoteHostSessions
|
sessions <- asks remoteHostSessions
|
||||||
crh <- asks currentRemoteHost
|
crh <- asks currentRemoteHost
|
||||||
deregistered <- atomically $
|
deregistered <-
|
||||||
|
atomically $
|
||||||
TM.lookup rhKey sessions >>= \case
|
TM.lookup rhKey sessions >>= \case
|
||||||
Nothing -> pure Nothing
|
Nothing -> pure Nothing
|
||||||
Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler
|
Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler
|
||||||
|
@ -401,7 +406,8 @@ findKnownRemoteCtrl = do
|
||||||
(RCCtrlPairing {ctrlFingerprint}, inv@(RCVerifiedInvitation RCInvitation {app})) <-
|
(RCCtrlPairing {ctrlFingerprint}, inv@(RCVerifiedInvitation RCInvitation {app})) <-
|
||||||
timeoutThrow (ChatErrorRemoteCtrl RCETimeout) discoveryTimeout . withAgent $ \a -> rcDiscoverCtrl a pairings
|
timeoutThrow (ChatErrorRemoteCtrl RCETimeout) discoveryTimeout . withAgent $ \a -> rcDiscoverCtrl a pairings
|
||||||
ctrlAppInfo_ <- (Just <$> parseCtrlAppInfo app) `catchChatError` const (pure Nothing)
|
ctrlAppInfo_ <- (Just <$> parseCtrlAppInfo app) `catchChatError` const (pure Nothing)
|
||||||
rc <- withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case
|
rc <-
|
||||||
|
withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case
|
||||||
Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl"
|
Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl"
|
||||||
Just rc -> pure rc
|
Just rc -> pure rc
|
||||||
atomically $ putTMVar foundCtrl (rc, inv)
|
atomically $ putTMVar foundCtrl (rc, inv)
|
||||||
|
@ -422,7 +428,7 @@ confirmRemoteCtrl rcId = do
|
||||||
pure $ Right (sseq, action, foundCtrl)
|
pure $ Right (sseq, action, foundCtrl)
|
||||||
_ -> pure . Left $ ChatErrorRemoteCtrl RCEBadState
|
_ -> pure . Left $ ChatErrorRemoteCtrl RCEBadState
|
||||||
uninterruptibleCancel listener
|
uninterruptibleCancel listener
|
||||||
(RemoteCtrl{remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found
|
(RemoteCtrl {remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found
|
||||||
unless (rcId == foundRcId) $ throwError $ ChatErrorRemoteCtrl RCEBadController
|
unless (rcId == foundRcId) $ throwError $ ChatErrorRemoteCtrl RCEBadController
|
||||||
connectRemoteCtrl verifiedInv sseq >>= \case
|
connectRemoteCtrl verifiedInv sseq >>= \case
|
||||||
(Nothing, _) -> throwChatError $ CEInternalError "connecting with a stored ctrl"
|
(Nothing, _) -> throwChatError $ CEInternalError "connecting with a stored ctrl"
|
||||||
|
@ -647,9 +653,11 @@ handleCtrlError sseq mkReason name action =
|
||||||
cancelActiveRemoteCtrl :: ChatMonad m => Maybe (SessionSeq, RemoteCtrlStopReason) -> m ()
|
cancelActiveRemoteCtrl :: ChatMonad m => Maybe (SessionSeq, RemoteCtrlStopReason) -> m ()
|
||||||
cancelActiveRemoteCtrl handlerInfo_ = handleAny (logError . tshow) $ do
|
cancelActiveRemoteCtrl handlerInfo_ = handleAny (logError . tshow) $ do
|
||||||
var <- asks remoteCtrlSession
|
var <- asks remoteCtrlSession
|
||||||
session_ <- atomically $ readTVar var >>= \case
|
session_ <-
|
||||||
|
atomically $
|
||||||
|
readTVar var >>= \case
|
||||||
Nothing -> pure Nothing
|
Nothing -> pure Nothing
|
||||||
Just (oldSeq, _) | maybe False (/= oldSeq) (fst <$> handlerInfo_) -> pure Nothing
|
Just (oldSeq, _) | (maybe False ((oldSeq /=) . fst) handlerInfo_) -> pure Nothing
|
||||||
Just (_, s) -> Just s <$ writeTVar var Nothing
|
Just (_, s) -> Just s <$ writeTVar var Nothing
|
||||||
forM_ session_ $ \session -> do
|
forM_ session_ $ \session -> do
|
||||||
liftIO $ cancelRemoteCtrl handlingError session
|
liftIO $ cancelRemoteCtrl handlingError session
|
||||||
|
|
|
@ -11,7 +11,7 @@ module Simplex.Chat.Remote.AppVersion
|
||||||
compatibleAppVersion,
|
compatibleAppVersion,
|
||||||
isAppCompatible,
|
isAppCompatible,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||||
import qualified Data.Aeson as J
|
import qualified Data.Aeson as J
|
||||||
|
|
|
@ -6,10 +6,8 @@ import Network.Socket
|
||||||
|
|
||||||
#include <HsNet.h>
|
#include <HsNet.h>
|
||||||
|
|
||||||
{- | Toggle multicast group membership.
|
-- | Toggle multicast group membership.
|
||||||
|
-- NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups.
|
||||||
NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups.
|
|
||||||
-}
|
|
||||||
setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ())
|
setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ())
|
||||||
setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do
|
setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do
|
||||||
#{poke struct ip_mreq, imr_multiaddr} mReqPtr group
|
#{poke struct ip_mreq, imr_multiaddr} mReqPtr group
|
||||||
|
|
|
@ -6,8 +6,8 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
module Simplex.Chat.Remote.Protocol where
|
module Simplex.Chat.Remote.Protocol where
|
||||||
|
|
||||||
|
@ -48,9 +48,9 @@ import Simplex.Messaging.Transport.Buffer (getBuffered)
|
||||||
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk)
|
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk)
|
||||||
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect)
|
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect)
|
||||||
import Simplex.Messaging.Util (liftEitherError, liftEitherWith, liftError, tshow)
|
import Simplex.Messaging.Util (liftEitherError, liftEitherWith, liftError, tshow)
|
||||||
import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode)
|
|
||||||
import Simplex.RemoteControl.Client (xrcpBlockSize)
|
import Simplex.RemoteControl.Client (xrcpBlockSize)
|
||||||
import qualified Simplex.RemoteControl.Client as RC
|
import qualified Simplex.RemoteControl.Client as RC
|
||||||
|
import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode)
|
||||||
import System.FilePath (takeFileName, (</>))
|
import System.FilePath (takeFileName, (</>))
|
||||||
import UnliftIO
|
import UnliftIO
|
||||||
|
|
||||||
|
@ -64,10 +64,10 @@ data RemoteCommand
|
||||||
|
|
||||||
data RemoteResponse
|
data RemoteResponse
|
||||||
= RRChatResponse {chatResponse :: ChatResponse}
|
= RRChatResponse {chatResponse :: ChatResponse}
|
||||||
| RRChatEvent {chatEvent :: Maybe ChatResponse} -- ^ 'Nothing' on poll timeout
|
| RRChatEvent {chatEvent :: Maybe ChatResponse} -- 'Nothing' on poll timeout
|
||||||
| RRFileStored {filePath :: String}
|
| RRFileStored {filePath :: String}
|
||||||
| RRFile {fileSize :: Word32, fileDigest :: FileDigest} -- provides attachment , fileDigest :: FileDigest
|
| RRFile {fileSize :: Word32, fileDigest :: FileDigest} -- provides attachment , fileDigest :: FileDigest
|
||||||
| RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- ^ The protocol error happened on the server side
|
| RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- The protocol error happened on the server side
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
-- Force platform-independent encoding as the types aren't UI-visible
|
-- Force platform-independent encoding as the types aren't UI-visible
|
||||||
|
@ -126,7 +126,7 @@ remoteStoreFile c localPath fileName = do
|
||||||
r -> badResponse r
|
r -> badResponse r
|
||||||
|
|
||||||
remoteGetFile :: RemoteHostClient -> FilePath -> RemoteFile -> ExceptT RemoteProtocolError IO ()
|
remoteGetFile :: RemoteHostClient -> FilePath -> RemoteFile -> ExceptT RemoteProtocolError IO ()
|
||||||
remoteGetFile c@RemoteHostClient{encryption} destDir rf@RemoteFile {fileSource = CryptoFile {filePath}} =
|
remoteGetFile c@RemoteHostClient {encryption} destDir rf@RemoteFile {fileSource = CryptoFile {filePath}} =
|
||||||
sendRemoteCommand c Nothing RCGetFile {file = rf} >>= \case
|
sendRemoteCommand c Nothing RCGetFile {file = rf} >>= \case
|
||||||
(getChunk, RRFile {fileSize, fileDigest}) -> do
|
(getChunk, RRFile {fileSize, fileDigest}) -> do
|
||||||
-- TODO we could optimize by checking size and hash before receiving the file
|
-- TODO we could optimize by checking size and hash before receiving the file
|
||||||
|
|
|
@ -5,15 +5,15 @@ module Simplex.Chat.Remote.Transport where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Data.ByteString.Builder (Builder, byteString)
|
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
|
import Data.ByteString.Builder (Builder, byteString)
|
||||||
import qualified Data.ByteString.Lazy as LB
|
import qualified Data.ByteString.Lazy as LB
|
||||||
import Data.Word (Word32)
|
import Data.Word (Word32)
|
||||||
import Simplex.FileTransfer.Description (FileDigest (..))
|
|
||||||
import Simplex.Chat.Remote.Types
|
import Simplex.Chat.Remote.Types
|
||||||
|
import Simplex.FileTransfer.Description (FileDigest (..))
|
||||||
|
import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sendEncFile)
|
||||||
import qualified Simplex.Messaging.Crypto as C
|
import qualified Simplex.Messaging.Crypto as C
|
||||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||||
import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sendEncFile)
|
|
||||||
import Simplex.Messaging.Encoding
|
import Simplex.Messaging.Encoding
|
||||||
import Simplex.Messaging.Util (liftEitherError, liftEitherWith)
|
import Simplex.Messaging.Util (liftEitherError, liftEitherWith)
|
||||||
import Simplex.RemoteControl.Types (RCErrorType (..))
|
import Simplex.RemoteControl.Types (RCErrorType (..))
|
||||||
|
|
|
@ -21,13 +21,13 @@ import Data.Text (Text)
|
||||||
import Simplex.Chat.Remote.AppVersion
|
import Simplex.Chat.Remote.AppVersion
|
||||||
import Simplex.Chat.Types (verificationCode)
|
import Simplex.Chat.Types (verificationCode)
|
||||||
import qualified Simplex.Messaging.Crypto as C
|
import qualified Simplex.Messaging.Crypto as C
|
||||||
|
import Simplex.Messaging.Crypto.File (CryptoFile)
|
||||||
import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret)
|
import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret)
|
||||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
|
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
|
||||||
|
import Simplex.Messaging.Transport (TLS (..))
|
||||||
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
|
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
|
||||||
import Simplex.RemoteControl.Client
|
import Simplex.RemoteControl.Client
|
||||||
import Simplex.RemoteControl.Types
|
import Simplex.RemoteControl.Types
|
||||||
import Simplex.Messaging.Crypto.File (CryptoFile)
|
|
||||||
import Simplex.Messaging.Transport (TLS (..))
|
|
||||||
|
|
||||||
data RemoteHostClient = RemoteHostClient
|
data RemoteHostClient = RemoteHostClient
|
||||||
{ hostEncoding :: PlatformEncoding,
|
{ hostEncoding :: PlatformEncoding,
|
||||||
|
|
|
@ -4,7 +4,6 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||||
|
|
||||||
module Simplex.Chat.Store.Connections
|
module Simplex.Chat.Store.Connections
|
||||||
|
@ -25,11 +24,11 @@ import Data.Text (Text)
|
||||||
import Data.Time.Clock (UTCTime (..))
|
import Data.Time.Clock (UTCTime (..))
|
||||||
import Database.SQLite.Simple (Only (..), (:.) (..))
|
import Database.SQLite.Simple (Only (..), (:.) (..))
|
||||||
import Database.SQLite.Simple.QQ (sql)
|
import Database.SQLite.Simple.QQ (sql)
|
||||||
|
import Simplex.Chat.Protocol
|
||||||
import Simplex.Chat.Store.Files
|
import Simplex.Chat.Store.Files
|
||||||
import Simplex.Chat.Store.Groups
|
import Simplex.Chat.Store.Groups
|
||||||
import Simplex.Chat.Store.Profiles
|
import Simplex.Chat.Store.Profiles
|
||||||
import Simplex.Chat.Store.Shared
|
import Simplex.Chat.Store.Shared
|
||||||
import Simplex.Chat.Protocol
|
|
||||||
import Simplex.Chat.Types
|
import Simplex.Chat.Types
|
||||||
import Simplex.Chat.Types.Preferences
|
import Simplex.Chat.Types.Preferences
|
||||||
import Simplex.Messaging.Agent.Protocol (ConnId)
|
import Simplex.Messaging.Agent.Protocol (ConnId)
|
||||||
|
@ -157,7 +156,8 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
|
||||||
|
|
||||||
getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
|
getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
|
||||||
getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
|
getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||||
connId_ <- maybeFirstRow fromOnly $
|
connId_ <-
|
||||||
|
maybeFirstRow fromOnly $
|
||||||
DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2)
|
DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2)
|
||||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
|
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
|
||||||
|
|
||||||
|
@ -167,7 +167,8 @@ getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) =
|
||||||
-- deleted connections are filtered out to allow re-connecting via same contact address
|
-- deleted connections are filtered out to allow re-connecting via same contact address
|
||||||
getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
|
getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
|
||||||
getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do
|
getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do
|
||||||
connId_ <- maybeFirstRow fromOnly $
|
connId_ <-
|
||||||
|
maybeFirstRow fromOnly $
|
||||||
DB.query
|
DB.query
|
||||||
db
|
db
|
||||||
[sql|
|
[sql|
|
||||||
|
|
|
@ -1,13 +1,12 @@
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
{-# LANGUAGE OverloadedRecordDot #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||||
|
|
||||||
module Simplex.Chat.Store.Direct
|
module Simplex.Chat.Store.Direct
|
||||||
|
@ -784,10 +783,8 @@ updateConnectionStatus :: DB.Connection -> Connection -> ConnStatus -> IO ()
|
||||||
updateConnectionStatus db Connection {connId} connStatus = do
|
updateConnectionStatus db Connection {connId} connStatus = do
|
||||||
currentTs <- getCurrentTime
|
currentTs <- getCurrentTime
|
||||||
if connStatus == ConnReady
|
if connStatus == ConnReady
|
||||||
then
|
then DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ?, conn_req_inv = NULL WHERE connection_id = ?" (connStatus, currentTs, connId)
|
||||||
DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ?, conn_req_inv = NULL WHERE connection_id = ?" (connStatus, currentTs, connId)
|
else DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId)
|
||||||
else
|
|
||||||
DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId)
|
|
||||||
|
|
||||||
updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO ()
|
updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO ()
|
||||||
updateContactSettings db User {userId} contactId ChatSettings {enableNtfs, sendRcpts, favorite} =
|
updateContactSettings db User {userId} contactId ChatSettings {enableNtfs, sendRcpts, favorite} =
|
||||||
|
@ -816,4 +813,3 @@ resetContactConnInitiated db User {userId} Connection {connId} = do
|
||||||
WHERE user_id = ? AND connection_id = ?
|
WHERE user_id = ? AND connection_id = ?
|
||||||
|]
|
|]
|
||||||
(updatedAt, userId, connId)
|
(updatedAt, userId, connId)
|
||||||
|
|
||||||
|
|
|
@ -109,7 +109,7 @@ import Simplex.Messaging.Protocol (SubscriptionMode (..))
|
||||||
|
|
||||||
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
|
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
|
||||||
getLiveSndFileTransfers db User {userId} = do
|
getLiveSndFileTransfers db User {userId} = do
|
||||||
cutoffTs <- addUTCTime (- week) <$> getCurrentTime
|
cutoffTs <- addUTCTime (-week) <$> getCurrentTime
|
||||||
fileIds :: [Int64] <-
|
fileIds :: [Int64] <-
|
||||||
map fromOnly
|
map fromOnly
|
||||||
<$> DB.query
|
<$> DB.query
|
||||||
|
@ -132,7 +132,7 @@ getLiveSndFileTransfers db User {userId} = do
|
||||||
|
|
||||||
getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer]
|
getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer]
|
||||||
getLiveRcvFileTransfers db user@User {userId} = do
|
getLiveRcvFileTransfers db user@User {userId} = do
|
||||||
cutoffTs <- addUTCTime (- week) <$> getCurrentTime
|
cutoffTs <- addUTCTime (-week) <$> getCurrentTime
|
||||||
fileIds :: [Int64] <-
|
fileIds :: [Int64] <-
|
||||||
map fromOnly
|
map fromOnly
|
||||||
<$> DB.query
|
<$> DB.query
|
||||||
|
@ -234,7 +234,8 @@ createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Conn
|
||||||
|
|
||||||
updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> ExceptT StoreError IO ()
|
updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> ExceptT StoreError IO ()
|
||||||
updateSndDirectFTDelivery _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
|
updateSndDirectFTDelivery _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
|
||||||
updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = liftIO $
|
updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId =
|
||||||
|
liftIO $
|
||||||
DB.execute
|
DB.execute
|
||||||
db
|
db
|
||||||
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
|
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
|
||||||
|
@ -724,7 +725,7 @@ removeFileCryptoArgs db fileId = do
|
||||||
|
|
||||||
getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer]
|
getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer]
|
||||||
getRcvFilesToReceive db user@User {userId} = do
|
getRcvFilesToReceive db user@User {userId} = do
|
||||||
cutoffTs <- addUTCTime (- (2 * nominalDay)) <$> getCurrentTime
|
cutoffTs <- addUTCTime (-(2 * nominalDay)) <$> getCurrentTime
|
||||||
fileIds :: [Int64] <-
|
fileIds :: [Int64] <-
|
||||||
map fromOnly
|
map fromOnly
|
||||||
<$> DB.query
|
<$> DB.query
|
||||||
|
|
|
@ -2,14 +2,13 @@
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE OverloadedRecordDot #-}
|
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||||
|
|
||||||
module Simplex.Chat.Store.Groups
|
module Simplex.Chat.Store.Groups
|
||||||
|
@ -122,7 +121,7 @@ import Crypto.Random (ChaChaDRG)
|
||||||
import Data.Either (rights)
|
import Data.Either (rights)
|
||||||
import Data.Int (Int64)
|
import Data.Int (Int64)
|
||||||
import Data.List (partition, sortOn)
|
import Data.List (partition, sortOn)
|
||||||
import Data.Maybe (fromMaybe, isNothing, catMaybes, isJust)
|
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
|
||||||
import Data.Ord (Down (..))
|
import Data.Ord (Down (..))
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||||||
|
@ -957,8 +956,9 @@ createNewMember_
|
||||||
:. (minV, maxV)
|
:. (minV, maxV)
|
||||||
)
|
)
|
||||||
groupMemberId <- insertedRowId db
|
groupMemberId <- insertedRowId db
|
||||||
pure GroupMember {
|
pure
|
||||||
groupMemberId,
|
GroupMember
|
||||||
|
{ groupMemberId,
|
||||||
groupId,
|
groupId,
|
||||||
memberId,
|
memberId,
|
||||||
memberRole,
|
memberRole,
|
||||||
|
@ -1317,7 +1317,8 @@ getGroupInfo db User {userId, userContactId} groupId =
|
||||||
|
|
||||||
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
|
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
|
||||||
getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
|
getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||||
groupId_ <- maybeFirstRow fromOnly $
|
groupId_ <-
|
||||||
|
maybeFirstRow fromOnly $
|
||||||
DB.query
|
DB.query
|
||||||
db
|
db
|
||||||
[sql|
|
[sql|
|
||||||
|
@ -1330,7 +1331,8 @@ getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSch
|
||||||
|
|
||||||
getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
|
getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
|
||||||
getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
|
getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
|
||||||
groupId_ <- maybeFirstRow fromOnly $
|
groupId_ <-
|
||||||
|
maybeFirstRow fromOnly $
|
||||||
DB.query
|
DB.query
|
||||||
db
|
db
|
||||||
[sql|
|
[sql|
|
||||||
|
|
|
@ -10,7 +10,6 @@
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||||
|
|
||||||
module Simplex.Chat.Store.Messages
|
module Simplex.Chat.Store.Messages
|
||||||
|
@ -199,12 +198,13 @@ createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMs
|
||||||
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs
|
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs
|
||||||
pure msg
|
pure msg
|
||||||
|
|
||||||
createNewRcvMessage :: forall e. (MsgEncodingI e) => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
|
createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
|
||||||
createNewRcvMessage db connOrGroupId NewMessage{chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember =
|
createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember =
|
||||||
case connOrGroupId of
|
case connOrGroupId of
|
||||||
ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing
|
ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing
|
||||||
GroupId groupId -> case sharedMsgId_ of
|
GroupId groupId -> case sharedMsgId_ of
|
||||||
Just sharedMsgId -> liftIO (duplicateGroupMsgMemberIds groupId sharedMsgId) >>= \case
|
Just sharedMsgId ->
|
||||||
|
liftIO (duplicateGroupMsgMemberIds groupId sharedMsgId) >>= \case
|
||||||
Just (duplAuthorId, duplFwdMemberId) ->
|
Just (duplAuthorId, duplFwdMemberId) ->
|
||||||
throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId
|
throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId
|
||||||
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
|
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
|
||||||
|
@ -212,8 +212,8 @@ createNewRcvMessage db connOrGroupId NewMessage{chatMsgEvent, msgBody} sharedMsg
|
||||||
where
|
where
|
||||||
duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId))
|
duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId))
|
||||||
duplicateGroupMsgMemberIds groupId sharedMsgId =
|
duplicateGroupMsgMemberIds groupId sharedMsgId =
|
||||||
maybeFirstRow id
|
maybeFirstRow id $
|
||||||
$ DB.query
|
DB.query
|
||||||
db
|
db
|
||||||
[sql|
|
[sql|
|
||||||
SELECT author_group_member_id, forwarded_by_group_member_id
|
SELECT author_group_member_id, forwarded_by_group_member_id
|
||||||
|
@ -232,7 +232,7 @@ createNewRcvMessage db connOrGroupId NewMessage{chatMsgEvent, msgBody} sharedMsg
|
||||||
|]
|
|]
|
||||||
(MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember)
|
(MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember)
|
||||||
msgId <- insertedRowId db
|
msgId <- insertedRowId db
|
||||||
pure RcvMessage{msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember}
|
pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember}
|
||||||
|
|
||||||
createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO ()
|
createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO ()
|
||||||
createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do
|
createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do
|
||||||
|
|
|
@ -8,7 +8,6 @@
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||||
|
|
||||||
module Simplex.Chat.Store.Profiles
|
module Simplex.Chat.Store.Profiles
|
||||||
|
@ -66,9 +65,9 @@ import Control.Monad.IO.Class
|
||||||
import qualified Data.Aeson.TH as J
|
import qualified Data.Aeson.TH as J
|
||||||
import Data.Functor (($>))
|
import Data.Functor (($>))
|
||||||
import Data.Int (Int64)
|
import Data.Int (Int64)
|
||||||
|
import Data.List.NonEmpty (NonEmpty)
|
||||||
import qualified Data.List.NonEmpty as L
|
import qualified Data.List.NonEmpty as L
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.List.NonEmpty (NonEmpty)
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||||
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||||||
|
@ -89,7 +88,7 @@ import Simplex.Messaging.Encoding.String
|
||||||
import Simplex.Messaging.Parsers (defaultJSON)
|
import Simplex.Messaging.Parsers (defaultJSON)
|
||||||
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode)
|
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode)
|
||||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||||
import Simplex.Messaging.Util (safeDecodeUtf8, eitherToMaybe)
|
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
|
||||||
|
|
||||||
createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User
|
createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User
|
||||||
createUserRecord db auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime
|
createUserRecord db auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime
|
||||||
|
@ -457,7 +456,8 @@ getUserContactLinkByConnReq db User {userId} (cReqSchema1, cReqSchema2) =
|
||||||
|
|
||||||
getContactWithoutConnViaAddress :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact)
|
getContactWithoutConnViaAddress :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact)
|
||||||
getContactWithoutConnViaAddress db user@User {userId} (cReqSchema1, cReqSchema2) = do
|
getContactWithoutConnViaAddress db user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||||
ctId_ <- maybeFirstRow fromOnly $
|
ctId_ <-
|
||||||
|
maybeFirstRow fromOnly $
|
||||||
DB.query
|
DB.query
|
||||||
db
|
db
|
||||||
[sql|
|
[sql|
|
||||||
|
|
|
@ -101,7 +101,7 @@ data StoreError
|
||||||
| SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId}
|
| SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId}
|
||||||
| SEDuplicateGroupMessage {groupId :: Int64, sharedMsgId :: SharedMsgId, authorGroupMemberId :: Maybe GroupMemberId, forwardedByGroupMemberId :: Maybe GroupMemberId}
|
| SEDuplicateGroupMessage {groupId :: Int64, sharedMsgId :: SharedMsgId, authorGroupMemberId :: Maybe GroupMemberId, forwardedByGroupMemberId :: Maybe GroupMemberId}
|
||||||
| SERemoteHostNotFound {remoteHostId :: RemoteHostId}
|
| SERemoteHostNotFound {remoteHostId :: RemoteHostId}
|
||||||
| SERemoteHostUnknown -- ^ attempting to store KnownHost without a known fingerprint
|
| SERemoteHostUnknown -- attempting to store KnownHost without a known fingerprint
|
||||||
| SERemoteHostDuplicateCA
|
| SERemoteHostDuplicateCA
|
||||||
| SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
|
| SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
|
||||||
| SERemoteCtrlDuplicateCA
|
| SERemoteCtrlDuplicateCA
|
||||||
|
|
|
@ -24,7 +24,7 @@ import Simplex.Chat (execChatCommand, processChatCommand)
|
||||||
import Simplex.Chat.Controller
|
import Simplex.Chat.Controller
|
||||||
import Simplex.Chat.Markdown
|
import Simplex.Chat.Markdown
|
||||||
import Simplex.Chat.Messages
|
import Simplex.Chat.Messages
|
||||||
import Simplex.Chat.Messages.CIContent (CIContent(..), SMsgDirection (..))
|
import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..))
|
||||||
import Simplex.Chat.Options
|
import Simplex.Chat.Options
|
||||||
import Simplex.Chat.Protocol (MsgContent (..), msgContentText)
|
import Simplex.Chat.Protocol (MsgContent (..), msgContentText)
|
||||||
import Simplex.Chat.Remote.Types (RHKey (..), RemoteHostId, RemoteHostInfo (..), RemoteHostSession (..))
|
import Simplex.Chat.Remote.Types (RHKey (..), RemoteHostId, RemoteHostInfo (..), RemoteHostSession (..))
|
||||||
|
@ -167,7 +167,8 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
|
||||||
void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc
|
void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc
|
||||||
_ -> pure ()
|
_ -> pure ()
|
||||||
logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s
|
logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s
|
||||||
getRemoteUser rhId = runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case
|
getRemoteUser rhId =
|
||||||
|
runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case
|
||||||
CRActiveUser {user} -> updateRemoteUser ct user rhId
|
CRActiveUser {user} -> updateRemoteUser ct user rhId
|
||||||
cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr
|
cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr
|
||||||
removeRemoteUser rhId = atomically $ TM.delete rhId (currentRemoteUsers ct)
|
removeRemoteUser rhId = atomically $ TM.delete rhId (currentRemoteUsers ct)
|
||||||
|
|
|
@ -17,7 +17,6 @@
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeFamilyDependencies #-}
|
{-# LANGUAGE TypeFamilyDependencies #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||||
|
|
||||||
{-# HLINT ignore "Use newtype instead of data" #-}
|
{-# HLINT ignore "Use newtype instead of data" #-}
|
||||||
|
@ -40,7 +39,7 @@ import qualified Data.Text as T
|
||||||
import Data.Time.Clock (UTCTime)
|
import Data.Time.Clock (UTCTime)
|
||||||
import Data.Typeable (Typeable)
|
import Data.Typeable (Typeable)
|
||||||
import Database.SQLite.Simple (ResultError (..), SQLData (..))
|
import Database.SQLite.Simple (ResultError (..), SQLData (..))
|
||||||
import Database.SQLite.Simple.FromField (returnError, FromField(..))
|
import Database.SQLite.Simple.FromField (FromField (..), returnError)
|
||||||
import Database.SQLite.Simple.Internal (Field (..))
|
import Database.SQLite.Simple.Internal (Field (..))
|
||||||
import Database.SQLite.Simple.Ok
|
import Database.SQLite.Simple.Ok
|
||||||
import Database.SQLite.Simple.ToField (ToField (..))
|
import Database.SQLite.Simple.ToField (ToField (..))
|
||||||
|
@ -50,7 +49,7 @@ import Simplex.FileTransfer.Description (FileDigest)
|
||||||
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
|
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
|
||||||
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
|
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
|
||||||
import Simplex.Messaging.Encoding.String
|
import Simplex.Messaging.Encoding.String
|
||||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON, enumJSON)
|
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, sumTypeJSON, taggedObjectJSON)
|
||||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
|
import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
|
||||||
import Simplex.Messaging.Util ((<$?>))
|
import Simplex.Messaging.Util ((<$?>))
|
||||||
import Simplex.Messaging.Version
|
import Simplex.Messaging.Version
|
||||||
|
@ -498,7 +497,7 @@ data LocalProfile = LocalProfile
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
localProfileId :: LocalProfile -> ProfileId
|
localProfileId :: LocalProfile -> ProfileId
|
||||||
localProfileId LocalProfile{profileId} = profileId
|
localProfileId LocalProfile {profileId} = profileId
|
||||||
|
|
||||||
toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile
|
toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile
|
||||||
toLocalProfile profileId Profile {displayName, fullName, image, contactLink, preferences} localAlias =
|
toLocalProfile profileId Profile {displayName, fullName, image, contactLink, preferences} localAlias =
|
||||||
|
|
|
@ -14,7 +14,6 @@
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeFamilyDependencies #-}
|
{-# LANGUAGE TypeFamilyDependencies #-}
|
||||||
|
|
||||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
|
|
||||||
module Simplex.Chat.Types.Util where
|
module Simplex.Chat.Types.Util where
|
||||||
|
|
||||||
import Data.Aeson (ToJSON, FromJSON)
|
import Data.Aeson (FromJSON, ToJSON)
|
||||||
import qualified Data.Aeson as J
|
import qualified Data.Aeson as J
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||||
|
|
|
@ -14,8 +14,8 @@ module Simplex.Chat.View where
|
||||||
|
|
||||||
import qualified Data.Aeson as J
|
import qualified Data.Aeson as J
|
||||||
import qualified Data.Aeson.TH as JQ
|
import qualified Data.Aeson.TH as JQ
|
||||||
import qualified Data.ByteString.Char8 as B
|
|
||||||
import Data.ByteString.Char8 (ByteString)
|
import Data.ByteString.Char8 (ByteString)
|
||||||
|
import qualified Data.ByteString.Char8 as B
|
||||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||||
import Data.Char (isSpace, toUpper)
|
import Data.Char (isSpace, toUpper)
|
||||||
import Data.Function (on)
|
import Data.Function (on)
|
||||||
|
@ -44,8 +44,8 @@ import Simplex.Chat.Markdown
|
||||||
import Simplex.Chat.Messages hiding (NewChatItem (..))
|
import Simplex.Chat.Messages hiding (NewChatItem (..))
|
||||||
import Simplex.Chat.Messages.CIContent
|
import Simplex.Chat.Messages.CIContent
|
||||||
import Simplex.Chat.Protocol
|
import Simplex.Chat.Protocol
|
||||||
|
import Simplex.Chat.Remote.AppVersion (AppVersion (..), pattern AppVersionRange)
|
||||||
import Simplex.Chat.Remote.Types
|
import Simplex.Chat.Remote.Types
|
||||||
import Simplex.Chat.Remote.AppVersion (pattern AppVersionRange, AppVersion (..))
|
|
||||||
import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..))
|
import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..))
|
||||||
import Simplex.Chat.Styled
|
import Simplex.Chat.Styled
|
||||||
import Simplex.Chat.Types
|
import Simplex.Chat.Types
|
||||||
|
@ -308,10 +308,10 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
||||||
<> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_
|
<> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_
|
||||||
CRRemoteCtrlList cs -> viewRemoteCtrls cs
|
CRRemoteCtrlList cs -> viewRemoteCtrls cs
|
||||||
CRRemoteCtrlFound {remoteCtrl = RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName}, ctrlAppInfo_, appVersion, compatible} ->
|
CRRemoteCtrlFound {remoteCtrl = RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName}, ctrlAppInfo_, appVersion, compatible} ->
|
||||||
[ "remote controller " <> sShow remoteCtrlId <> " found: "
|
[ ("remote controller " <> sShow remoteCtrlId <> " found: ")
|
||||||
<> maybe (deviceName <> "not compatible") (\info -> viewRemoteCtrl info appVersion compatible) ctrlAppInfo_
|
<> maybe (deviceName <> "not compatible") (\info -> viewRemoteCtrl info appVersion compatible) ctrlAppInfo_
|
||||||
]
|
]
|
||||||
<> [ "use " <> highlight ("/confirm remote ctrl " <> show remoteCtrlId) <> " to connect" | isJust ctrlAppInfo_ && compatible]
|
<> ["use " <> highlight ("/confirm remote ctrl " <> show remoteCtrlId) <> " to connect" | isJust ctrlAppInfo_ && compatible]
|
||||||
where
|
where
|
||||||
deviceName = if T.null ctrlDeviceName then "" else plain ctrlDeviceName <> ", "
|
deviceName = if T.null ctrlDeviceName then "" else plain ctrlDeviceName <> ", "
|
||||||
CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion} ->
|
CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion} ->
|
||||||
|
@ -511,7 +511,9 @@ viewChats ts tz = concatMap chatPreview . reverse
|
||||||
|
|
||||||
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
|
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
|
||||||
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember}, content, quotedItem, file} doShow ts tz =
|
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember}, content, quotedItem, file} doShow ts tz =
|
||||||
withGroupMsgForwarded . withItemDeleted <$> (case chat of
|
withGroupMsgForwarded . withItemDeleted <$> viewCI
|
||||||
|
where
|
||||||
|
viewCI = case chat of
|
||||||
DirectChat c -> case chatDir of
|
DirectChat c -> case chatDir of
|
||||||
CIDirectSnd -> case content of
|
CIDirectSnd -> case content of
|
||||||
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
|
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
|
||||||
|
@ -545,8 +547,7 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember},
|
||||||
from = ttyFromGroup g m
|
from = ttyFromGroup g m
|
||||||
where
|
where
|
||||||
quote = maybe [] (groupQuote g) quotedItem
|
quote = maybe [] (groupQuote g) quotedItem
|
||||||
_ -> [])
|
_ -> []
|
||||||
where
|
|
||||||
withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of
|
withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of
|
||||||
Nothing -> item
|
Nothing -> item
|
||||||
Just t -> item <> styled (colored Red) (" [" <> t <> "]")
|
Just t -> item <> styled (colored Red) (" [" <> t <> "]")
|
||||||
|
@ -788,7 +789,7 @@ viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of
|
||||||
viewContactsList :: [Contact] -> [StyledString]
|
viewContactsList :: [Contact] -> [StyledString]
|
||||||
viewContactsList =
|
viewContactsList =
|
||||||
let getLDN :: Contact -> ContactName
|
let getLDN :: Contact -> ContactName
|
||||||
getLDN Contact{localDisplayName} = localDisplayName
|
getLDN Contact {localDisplayName} = localDisplayName
|
||||||
ldn = T.toLower . getLDN
|
ldn = T.toLower . getLDN
|
||||||
in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn
|
in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn
|
||||||
where
|
where
|
||||||
|
@ -823,8 +824,8 @@ simplexChatContact (CRContactUri crData) = CRContactUri crData {crScheme = simpl
|
||||||
autoAcceptStatus_ :: Maybe AutoAccept -> [StyledString]
|
autoAcceptStatus_ :: Maybe AutoAccept -> [StyledString]
|
||||||
autoAcceptStatus_ = \case
|
autoAcceptStatus_ = \case
|
||||||
Just AutoAccept {acceptIncognito, autoReply} ->
|
Just AutoAccept {acceptIncognito, autoReply} ->
|
||||||
("auto_accept on" <> if acceptIncognito then ", incognito" else "") :
|
("auto_accept on" <> if acceptIncognito then ", incognito" else "")
|
||||||
maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply
|
: maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply
|
||||||
_ -> ["auto_accept off"]
|
_ -> ["auto_accept off"]
|
||||||
|
|
||||||
groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> GroupMemberRole -> [StyledString]
|
groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> GroupMemberRole -> [StyledString]
|
||||||
|
@ -907,8 +908,8 @@ viewJoinedGroupMember g m =
|
||||||
|
|
||||||
viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString]
|
viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString]
|
||||||
viewReceivedGroupInvitation g c role =
|
viewReceivedGroupInvitation g c role =
|
||||||
ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role) :
|
ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role)
|
||||||
case incognitoMembershipProfile g of
|
: case incognitoMembershipProfile g of
|
||||||
Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)]
|
Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)]
|
||||||
Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"]
|
Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"]
|
||||||
|
|
||||||
|
@ -996,13 +997,13 @@ viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs
|
||||||
GSMemRemoved -> delete "you are removed"
|
GSMemRemoved -> delete "you are removed"
|
||||||
GSMemLeft -> delete "you left"
|
GSMemLeft -> delete "you left"
|
||||||
GSMemGroupDeleted -> delete "group deleted"
|
GSMemGroupDeleted -> delete "group deleted"
|
||||||
_ -> " (" <> memberCount <>
|
_ -> " (" <> memberCount <> viewNtf <> ")"
|
||||||
case enableNtfs of
|
where
|
||||||
MFAll -> ")"
|
viewNtf = case enableNtfs of
|
||||||
|
MFAll -> ""
|
||||||
MFNone -> ", muted, " <> unmute
|
MFNone -> ", muted, " <> unmute
|
||||||
MFMentions -> ", mentions only, " <> unmute
|
MFMentions -> ", mentions only, " <> unmute
|
||||||
where
|
unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g)
|
||||||
unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g) <> ")"
|
|
||||||
delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")"
|
delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")"
|
||||||
memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s"
|
memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s"
|
||||||
|
|
||||||
|
@ -1551,7 +1552,8 @@ receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIF
|
||||||
cfArgsStr (Just cfArgs) = [plain (cryptoFileArgsStr testView cfArgs) | status == "completed"]
|
cfArgsStr (Just cfArgs) = [plain (cryptoFileArgsStr testView cfArgs) | status == "completed"]
|
||||||
cfArgsStr _ = []
|
cfArgsStr _ = []
|
||||||
getRemoteFileStr = case hu of
|
getRemoteFileStr = case hu of
|
||||||
(Just rhId, Just User {userId}) | status == "completed" ->
|
(Just rhId, Just User {userId})
|
||||||
|
| status == "completed" ->
|
||||||
[ "File received to connected remote host " <> sShow rhId,
|
[ "File received to connected remote host " <> sShow rhId,
|
||||||
"To download to this device use:",
|
"To download to this device use:",
|
||||||
highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f}))
|
highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f}))
|
||||||
|
@ -1591,7 +1593,7 @@ viewFileTransferStatus (FTSnd FileTransferMeta {cancelled} fts@(ft : _), chunksN
|
||||||
[recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus]
|
[recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus]
|
||||||
recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses
|
recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses
|
||||||
fs :: SndFileTransfer -> FileStatus
|
fs :: SndFileTransfer -> FileStatus
|
||||||
fs SndFileTransfer{fileStatus} = fileStatus
|
fs SndFileTransfer {fileStatus} = fileStatus
|
||||||
recipientsTransferStatus [] = []
|
recipientsTransferStatus [] = []
|
||||||
recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts]
|
recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts]
|
||||||
where
|
where
|
||||||
|
@ -1763,7 +1765,8 @@ viewChatError logLevel testView = \case
|
||||||
CEEmptyUserPassword _ -> ["user password is required"]
|
CEEmptyUserPassword _ -> ["user password is required"]
|
||||||
CEUserAlreadyHidden _ -> ["user is already hidden"]
|
CEUserAlreadyHidden _ -> ["user is already hidden"]
|
||||||
CEUserNotHidden _ -> ["user is not hidden"]
|
CEUserNotHidden _ -> ["user is not hidden"]
|
||||||
CEInvalidDisplayName {displayName, validName} -> map plain $
|
CEInvalidDisplayName {displayName, validName} ->
|
||||||
|
map plain $
|
||||||
["invalid display name: " <> viewName displayName]
|
["invalid display name: " <> viewName displayName]
|
||||||
<> ["you could use this one: " <> viewName validName | not (T.null validName)]
|
<> ["you could use this one: " <> viewName validName | not (T.null validName)]
|
||||||
CEChatNotStarted -> ["error: chat not started"]
|
CEChatNotStarted -> ["error: chat not started"]
|
||||||
|
|
|
@ -5,7 +5,6 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||||
|
|
||||||
module ChatClient where
|
module ChatClient where
|
||||||
|
|
|
@ -259,7 +259,6 @@ testPlanInvitationLinkOk =
|
||||||
|
|
||||||
bob ##> ("/_connect plan 1 " <> inv)
|
bob ##> ("/_connect plan 1 " <> inv)
|
||||||
bob <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
|
bob <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
|
||||||
|
|
||||||
alice <##> bob
|
alice <##> bob
|
||||||
|
|
||||||
testPlanInvitationLinkOwn :: HasCallStack => FilePath -> IO ()
|
testPlanInvitationLinkOwn :: HasCallStack => FilePath -> IO ()
|
||||||
|
@ -283,7 +282,6 @@ testPlanInvitationLinkOwn tmp =
|
||||||
|
|
||||||
alice ##> ("/_connect plan 1 " <> inv)
|
alice ##> ("/_connect plan 1 " <> inv)
|
||||||
alice <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
|
alice <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
|
||||||
|
|
||||||
alice @@@ [("@alice_1", lastChatFeature), ("@alice_2", lastChatFeature)]
|
alice @@@ [("@alice_1", lastChatFeature), ("@alice_2", lastChatFeature)]
|
||||||
alice `send` "@alice_2 hi"
|
alice `send` "@alice_2 hi"
|
||||||
alice
|
alice
|
||||||
|
@ -1213,31 +1211,34 @@ testMuteGroup =
|
||||||
cath `send` "> #team (hello) hello too!"
|
cath `send` "> #team (hello) hello too!"
|
||||||
cath <# "#team > bob hello"
|
cath <# "#team > bob hello"
|
||||||
cath <## " hello too!"
|
cath <## " hello too!"
|
||||||
concurrently_
|
concurrentlyN_
|
||||||
(bob </)
|
[ (bob </),
|
||||||
( do alice <# "#team cath> > bob hello"
|
do
|
||||||
|
alice <# "#team cath> > bob hello"
|
||||||
alice <## " hello too!"
|
alice <## " hello too!"
|
||||||
)
|
]
|
||||||
bob ##> "/unmute mentions #team"
|
bob ##> "/unmute mentions #team"
|
||||||
bob <## "ok"
|
bob <## "ok"
|
||||||
alice `send` "> #team @bob (hello) hey bob!"
|
alice `send` "> #team @bob (hello) hey bob!"
|
||||||
alice <# "#team > bob hello"
|
alice <# "#team > bob hello"
|
||||||
alice <## " hey bob!"
|
alice <## " hey bob!"
|
||||||
concurrently_
|
concurrentlyN_
|
||||||
( do bob <# "#team alice> > bob hello"
|
[ do
|
||||||
bob <## " hey bob!"
|
bob <# "#team alice> > bob hello"
|
||||||
)
|
bob <## " hey bob!",
|
||||||
( do cath <# "#team alice> > bob hello"
|
do
|
||||||
|
cath <# "#team alice> > bob hello"
|
||||||
cath <## " hey bob!"
|
cath <## " hey bob!"
|
||||||
)
|
]
|
||||||
alice `send` "> #team @cath (hello) hey cath!"
|
alice `send` "> #team @cath (hello) hey cath!"
|
||||||
alice <# "#team > cath hello too!"
|
alice <# "#team > cath hello too!"
|
||||||
alice <## " hey cath!"
|
alice <## " hey cath!"
|
||||||
concurrently_
|
concurrentlyN_
|
||||||
(bob </)
|
[ (bob </),
|
||||||
( do cath <# "#team alice> > cath hello too!"
|
do
|
||||||
|
cath <# "#team alice> > cath hello too!"
|
||||||
cath <## " hey cath!"
|
cath <## " hey cath!"
|
||||||
)
|
]
|
||||||
bob ##> "/gs"
|
bob ##> "/gs"
|
||||||
bob <## "#team (3 members, mentions only, you can /unmute #team)"
|
bob <## "#team (3 members, mentions only, you can /unmute #team)"
|
||||||
bob ##> "/unmute #team"
|
bob ##> "/unmute #team"
|
||||||
|
|
|
@ -1,7 +1,6 @@
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PostfixOperators #-}
|
{-# LANGUAGE PostfixOperators #-}
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||||
|
|
||||||
module ChatTests.Files where
|
module ChatTests.Files where
|
||||||
|
|
|
@ -7,7 +7,7 @@ import ChatClient
|
||||||
import ChatTests.Utils
|
import ChatTests.Utils
|
||||||
import Control.Concurrent (threadDelay)
|
import Control.Concurrent (threadDelay)
|
||||||
import Control.Concurrent.Async (concurrently_)
|
import Control.Concurrent.Async (concurrently_)
|
||||||
import Control.Monad (when, void)
|
import Control.Monad (void, when)
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import Data.List (isInfixOf)
|
import Data.List (isInfixOf)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
@ -122,7 +122,8 @@ chatGroupTests = do
|
||||||
-- because host uses current code and sends version in MemberInfo
|
-- because host uses current code and sends version in MemberInfo
|
||||||
testNoDirect vrMem2 vrMem3 noConns =
|
testNoDirect vrMem2 vrMem3 noConns =
|
||||||
it
|
it
|
||||||
( "host " <> vRangeStr supportedChatVRange
|
( "host "
|
||||||
|
<> vRangeStr supportedChatVRange
|
||||||
<> (", 2nd mem " <> vRangeStr vrMem2)
|
<> (", 2nd mem " <> vRangeStr vrMem2)
|
||||||
<> (", 3rd mem " <> vRangeStr vrMem3)
|
<> (", 3rd mem " <> vRangeStr vrMem3)
|
||||||
<> (if noConns then " : 2 <!!> 3" else " : 2 <##> 3")
|
<> (if noConns then " : 2 <!!> 3" else " : 2 <##> 3")
|
||||||
|
@ -3859,11 +3860,9 @@ testMemberContactProfileUpdate =
|
||||||
bob #> "#team hello too"
|
bob #> "#team hello too"
|
||||||
alice <# "#team rob> hello too"
|
alice <# "#team rob> hello too"
|
||||||
cath <# "#team bob> hello too" -- not updated profile
|
cath <# "#team bob> hello too" -- not updated profile
|
||||||
|
|
||||||
cath #> "#team hello there"
|
cath #> "#team hello there"
|
||||||
alice <# "#team kate> hello there"
|
alice <# "#team kate> hello there"
|
||||||
bob <# "#team cath> hello there" -- not updated profile
|
bob <# "#team cath> hello there" -- not updated profile
|
||||||
|
|
||||||
bob `send` "@cath hi"
|
bob `send` "@cath hi"
|
||||||
bob
|
bob
|
||||||
<### [ "member #team cath does not have direct connection, creating",
|
<### [ "member #team cath does not have direct connection, creating",
|
||||||
|
@ -3903,7 +3902,6 @@ testMemberContactProfileUpdate =
|
||||||
bob #> "#team hello too"
|
bob #> "#team hello too"
|
||||||
alice <# "#team rob> hello too"
|
alice <# "#team rob> hello too"
|
||||||
cath <# "#team rob> hello too" -- updated profile
|
cath <# "#team rob> hello too" -- updated profile
|
||||||
|
|
||||||
cath #> "#team hello there"
|
cath #> "#team hello there"
|
||||||
alice <# "#team kate> hello there"
|
alice <# "#team kate> hello there"
|
||||||
bob <# "#team kate> hello there" -- updated profile
|
bob <# "#team kate> hello there" -- updated profile
|
||||||
|
@ -3941,7 +3939,6 @@ setupGroupForwarding3 gName alice bob cath = do
|
||||||
createGroup3 gName alice bob cath
|
createGroup3 gName alice bob cath
|
||||||
|
|
||||||
threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected
|
threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected
|
||||||
|
|
||||||
void $ withCCTransaction bob $ \db ->
|
void $ withCCTransaction bob $ \db ->
|
||||||
DB.execute_ db "UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3"
|
DB.execute_ db "UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3"
|
||||||
void $ withCCTransaction cath $ \db ->
|
void $ withCCTransaction cath $ \db ->
|
||||||
|
@ -3956,7 +3953,6 @@ testGroupMsgForwardDeduplicate =
|
||||||
createGroup3 "team" alice bob cath
|
createGroup3 "team" alice bob cath
|
||||||
|
|
||||||
threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected
|
threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected
|
||||||
|
|
||||||
void $ withCCTransaction alice $ \db ->
|
void $ withCCTransaction alice $ \db ->
|
||||||
DB.execute_ db "UPDATE group_member_intros SET intro_status='fwd'"
|
DB.execute_ db "UPDATE group_member_intros SET intro_status='fwd'"
|
||||||
|
|
||||||
|
@ -4001,7 +3997,6 @@ testGroupMsgForwardEdit =
|
||||||
bob <# "#team [edited] hello there"
|
bob <# "#team [edited] hello there"
|
||||||
alice <# "#team bob> [edited] hello there"
|
alice <# "#team bob> [edited] hello there"
|
||||||
cath <# "#team bob> [edited] hello there" -- TODO show as forwarded
|
cath <# "#team bob> [edited] hello there" -- TODO show as forwarded
|
||||||
|
|
||||||
alice ##> "/tail #team 1"
|
alice ##> "/tail #team 1"
|
||||||
alice <# "#team bob> hello there"
|
alice <# "#team bob> hello there"
|
||||||
|
|
||||||
|
|
|
@ -7,16 +7,16 @@ import ChatClient
|
||||||
import ChatTests.Utils
|
import ChatTests.Utils
|
||||||
import Control.Concurrent (threadDelay)
|
import Control.Concurrent (threadDelay)
|
||||||
import Control.Concurrent.Async (concurrently_)
|
import Control.Concurrent.Async (concurrently_)
|
||||||
|
import Control.Monad
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||||
import qualified Data.ByteString.Char8 as B
|
import qualified Data.ByteString.Char8 as B
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
import Simplex.Chat.Store.Shared (createContact)
|
||||||
import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..), Profile (..))
|
import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..), Profile (..))
|
||||||
|
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||||
import System.Directory (copyFile, createDirectoryIfMissing)
|
import System.Directory (copyFile, createDirectoryIfMissing)
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import Simplex.Chat.Store.Shared (createContact)
|
|
||||||
import Control.Monad
|
|
||||||
import Simplex.Messaging.Encoding.String (StrEncoding(..))
|
|
||||||
|
|
||||||
chatProfileTests :: SpecWith FilePath
|
chatProfileTests :: SpecWith FilePath
|
||||||
chatProfileTests = do
|
chatProfileTests = do
|
||||||
|
@ -633,7 +633,7 @@ testPlanAddressOwn tmp =
|
||||||
alice <## "alice_1 (Alice) wants to connect to you!"
|
alice <## "alice_1 (Alice) wants to connect to you!"
|
||||||
alice <## "to accept: /ac alice_1"
|
alice <## "to accept: /ac alice_1"
|
||||||
alice <## "to reject: /rc alice_1 (the sender will NOT be notified)"
|
alice <## "to reject: /rc alice_1 (the sender will NOT be notified)"
|
||||||
alice @@@ [("<@alice_1", ""), (":2","")]
|
alice @@@ [("<@alice_1", ""), (":2", "")]
|
||||||
alice ##> "/ac alice_1"
|
alice ##> "/ac alice_1"
|
||||||
alice <## "alice_1 (Alice): accepting contact request..."
|
alice <## "alice_1 (Alice): accepting contact request..."
|
||||||
alice
|
alice
|
||||||
|
|
|
@ -310,7 +310,7 @@ getInAnyOrder f cc ls = do
|
||||||
Predicate p -> p l
|
Predicate p -> p l
|
||||||
filterFirst :: (a -> Bool) -> [a] -> [a]
|
filterFirst :: (a -> Bool) -> [a] -> [a]
|
||||||
filterFirst _ [] = []
|
filterFirst _ [] = []
|
||||||
filterFirst p (x:xs)
|
filterFirst p (x : xs)
|
||||||
| p x = xs
|
| p x = xs
|
||||||
| otherwise = x : filterFirst p xs
|
| otherwise = x : filterFirst p xs
|
||||||
|
|
||||||
|
|
|
@ -13,8 +13,8 @@ import RemoteTests
|
||||||
import SchemaDump
|
import SchemaDump
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import UnliftIO.Temporary (withTempDirectory)
|
import UnliftIO.Temporary (withTempDirectory)
|
||||||
import ViewTests
|
|
||||||
import ValidNames
|
import ValidNames
|
||||||
|
import ViewTests
|
||||||
import WebRTCTests
|
import WebRTCTests
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue