mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +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 Simplex.Chat.Controller
|
||||
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 System.FilePath
|
||||
import UnliftIO.Directory
|
||||
|
|
|
@ -6,8 +6,8 @@ module Simplex.Chat.Bot.KnownContacts where
|
|||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Options.Applicative
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||
|
|
|
@ -225,4 +225,3 @@ instance FromField CallState where
|
|||
fromField = fromTextField_ decodeJSON
|
||||
|
||||
$(J.deriveJSON defaultJSON ''RcvCallInvitation)
|
||||
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
@ -426,19 +426,19 @@ data ChatCommand
|
|||
| SetGroupTimedMessages GroupName (Maybe Int)
|
||||
| SetLocalDeviceName Text
|
||||
| ListRemoteHosts
|
||||
| StartRemoteHost (Maybe (RemoteHostId, Bool)) -- ^ Start new or known remote host with optional multicast for known host
|
||||
| SwitchRemoteHost (Maybe RemoteHostId) -- ^ Switch current remote host
|
||||
| StopRemoteHost RHKey -- ^ Shut down a running session
|
||||
| DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data
|
||||
| StartRemoteHost (Maybe (RemoteHostId, Bool)) -- Start new or known remote host with optional multicast for known host
|
||||
| SwitchRemoteHost (Maybe RemoteHostId) -- Switch current remote host
|
||||
| StopRemoteHost RHKey -- Shut down a running session
|
||||
| DeleteRemoteHost RemoteHostId -- Unregister remote host and remove its data
|
||||
| StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath}
|
||||
| GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile}
|
||||
| ConnectRemoteCtrl RCSignedInvitation -- ^ Connect new or existing controller via OOB data
|
||||
| FindKnownRemoteCtrl -- ^ Start listening for announcements from all existing controllers
|
||||
| ConfirmRemoteCtrl RemoteCtrlId -- ^ Confirm the connection with found controller
|
||||
| VerifyRemoteCtrlSession Text -- ^ Verify remote controller session
|
||||
| ConnectRemoteCtrl RCSignedInvitation -- Connect new or existing controller via OOB data
|
||||
| FindKnownRemoteCtrl -- Start listening for announcements from all existing controllers
|
||||
| ConfirmRemoteCtrl RemoteCtrlId -- Confirm the connection with found controller
|
||||
| VerifyRemoteCtrlSession Text -- Verify remote controller session
|
||||
| ListRemoteCtrls
|
||||
| StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session
|
||||
| DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a remote controller session
|
||||
| StopRemoteCtrl -- Stop listening for announcements or terminate an active session
|
||||
| DeleteRemoteCtrl RemoteCtrlId -- Remove all local data associated with a remote controller session
|
||||
| QuitChat
|
||||
| ShowVersion
|
||||
| DebugLocks
|
||||
|
@ -1072,13 +1072,13 @@ throwDBError = throwError . ChatErrorDatabase
|
|||
|
||||
-- TODO review errors, some of it can be covered by HTTP2 errors
|
||||
data RemoteHostError
|
||||
= RHEMissing -- ^ No remote session matches this identifier
|
||||
| RHEInactive -- ^ A session exists, but not active
|
||||
| RHEBusy -- ^ A session is already running
|
||||
= RHEMissing -- No remote session matches this identifier
|
||||
| RHEInactive -- A session exists, but not active
|
||||
| RHEBusy -- A session is already running
|
||||
| RHETimeout
|
||||
| RHEBadState -- ^ Illegal state transition
|
||||
| RHEBadState -- Illegal state transition
|
||||
| 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?
|
||||
| RHEProtocolError RemoteProtocolError
|
||||
deriving (Show, Exception)
|
||||
|
@ -1091,13 +1091,14 @@ data RemoteHostStopReason
|
|||
|
||||
-- TODO review errors, some of it can be covered by HTTP2 errors
|
||||
data RemoteCtrlError
|
||||
= RCEInactive -- ^ No session is running
|
||||
| RCEBadState -- ^ A session is in a wrong state for the current operation
|
||||
| RCEBusy -- ^ A session is already running
|
||||
= RCEInactive -- No session is running
|
||||
| RCEBadState -- A session is in a wrong state for the current operation
|
||||
| RCEBusy -- A session is already running
|
||||
| RCETimeout
|
||||
| RCENoKnownControllers -- ^ No previously-contacted controllers to discover
|
||||
| RCEBadController -- ^ Attempting to confirm a found controller with another ID
|
||||
| RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected by a controller
|
||||
| RCENoKnownControllers -- No previously-contacted controllers to discover
|
||||
| RCEBadController -- Attempting to confirm a found controller with another ID
|
||||
| -- | A session disconnected by a controller
|
||||
RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text}
|
||||
| RCEBadInvitation
|
||||
| RCEBadVersion {appVersion :: AppVersion}
|
||||
| RCEHTTP2Error {http2Error :: Text} -- TODO currently not used
|
||||
|
@ -1223,8 +1224,8 @@ toView event = do
|
|||
session <- asks remoteCtrlSession
|
||||
atomically $
|
||||
readTVar session >>= \case
|
||||
Just (_, RCSessionConnected {remoteOutputQ}) | allowRemoteEvent event ->
|
||||
writeTBQueue remoteOutputQ event
|
||||
Just (_, RCSessionConnected {remoteOutputQ})
|
||||
| allowRemoteEvent event -> writeTBQueue remoteOutputQ event
|
||||
-- TODO potentially, it should hold some events while connecting
|
||||
_ -> writeTBQueue localQ (Nothing, Nothing, event)
|
||||
|
||||
|
|
|
@ -35,9 +35,9 @@ runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController
|
|||
runSimplexChat ChatOpts {maintenance} u cc chat
|
||||
| maintenance = wait =<< async (chat u cc)
|
||||
| otherwise = do
|
||||
a1 <- runReaderT (startChatController True True True) cc
|
||||
a2 <- async $ chat u cc
|
||||
waitEither_ a1 a2
|
||||
a1 <- runReaderT (startChatController True True True) cc
|
||||
a2 <- async $ chat u cc
|
||||
waitEither_ a1 a2
|
||||
|
||||
sendChatCmdStr :: ChatController -> String -> IO ChatResponse
|
||||
sendChatCmdStr cc s = runReaderT (execChatCommand Nothing . encodeUtf8 $ T.pack s) cc
|
||||
|
|
|
@ -6,8 +6,8 @@ module Simplex.Chat.Files where
|
|||
import Control.Monad.IO.Class
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Messaging.Util (ifM)
|
||||
import System.FilePath (splitExtensions, combine)
|
||||
import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, getHomeDirectory, doesDirectoryExist)
|
||||
import System.FilePath (combine, splitExtensions)
|
||||
import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getHomeDirectory, getTemporaryDirectory)
|
||||
|
||||
uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
|
||||
uniqueCombine fPath fName = tryCombine (0 :: Int)
|
||||
|
|
|
@ -19,7 +19,7 @@ import qualified Data.Attoparsec.Text as A
|
|||
import Data.Char (isDigit, isPunctuation)
|
||||
import Data.Either (fromRight)
|
||||
import Data.Functor (($>))
|
||||
import Data.List (intercalate, foldl')
|
||||
import Data.List (foldl', intercalate)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (fromMaybe, isNothing)
|
||||
|
@ -85,16 +85,18 @@ newtype FormatColor = FormatColor Color
|
|||
deriving (Eq, Show)
|
||||
|
||||
instance FromJSON FormatColor where
|
||||
parseJSON = J.withText "FormatColor" $ fmap FormatColor . \case
|
||||
"red" -> pure Red
|
||||
"green" -> pure Green
|
||||
"blue" -> pure Blue
|
||||
"yellow" -> pure Yellow
|
||||
"cyan" -> pure Cyan
|
||||
"magenta" -> pure Magenta
|
||||
"black" -> pure Black
|
||||
"white" -> pure White
|
||||
unexpected -> fail $ "unexpected FormatColor: " <> show unexpected
|
||||
parseJSON =
|
||||
J.withText "FormatColor" $
|
||||
fmap FormatColor . \case
|
||||
"red" -> pure Red
|
||||
"green" -> pure Green
|
||||
"blue" -> pure Blue
|
||||
"yellow" -> pure Yellow
|
||||
"cyan" -> pure Cyan
|
||||
"magenta" -> pure Magenta
|
||||
"black" -> pure Black
|
||||
"white" -> pure White
|
||||
unexpected -> fail $ "unexpected FormatColor: " <> show unexpected
|
||||
|
||||
instance ToJSON FormatColor where
|
||||
toJSON (FormatColor c) = case c of
|
||||
|
@ -167,14 +169,14 @@ markdownP = mconcat <$> A.many' fragmentP
|
|||
md :: Char -> Format -> Text -> Markdown
|
||||
md c f s
|
||||
| T.null s || T.head s == ' ' || T.last s == ' ' =
|
||||
unmarked $ c `T.cons` s `T.snoc` c
|
||||
unmarked $ c `T.cons` s `T.snoc` c
|
||||
| otherwise = markdown f s
|
||||
secretP :: Parser Markdown
|
||||
secretP = secret <$> A.takeWhile (== '#') <*> A.takeTill (== '#') <*> A.takeWhile (== '#')
|
||||
secret :: Text -> Text -> Text -> Markdown
|
||||
secret b s a
|
||||
| T.null a || T.null s || T.head s == ' ' || T.last s == ' ' =
|
||||
unmarked $ '#' `T.cons` ss
|
||||
unmarked $ '#' `T.cons` ss
|
||||
| otherwise = markdown Secret $ T.init ss
|
||||
where
|
||||
ss = b <> s <> a
|
||||
|
@ -215,9 +217,9 @@ markdownP = mconcat <$> A.many' fragmentP
|
|||
wordMD s
|
||||
| T.null s = unmarked s
|
||||
| isUri s =
|
||||
let t = T.takeWhileEnd isPunctuation s
|
||||
uri = uriMarkdown $ T.dropWhileEnd isPunctuation s
|
||||
in if T.null t then uri else uri :|: unmarked t
|
||||
let t = T.takeWhileEnd isPunctuation s
|
||||
uri = uriMarkdown $ T.dropWhileEnd isPunctuation s
|
||||
in if T.null t then uri else uri :|: unmarked t
|
||||
| isEmail s = markdown Email s
|
||||
| otherwise = unmarked s
|
||||
uriMarkdown s = case strDecode $ encodeUtf8 s of
|
||||
|
|
|
@ -11,7 +11,6 @@
|
|||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Chat.Messages where
|
||||
|
@ -44,7 +43,7 @@ import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptSta
|
|||
import Simplex.Messaging.Crypto.File (CryptoFile (..))
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
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.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
|
||||
|
||||
|
@ -345,7 +344,7 @@ contactTimedTTL Contact {mergedPreferences = ContactUserPreferences {timedMessag
|
|||
| forUser enabled && forContact enabled = Just ttl
|
||||
| otherwise = Nothing
|
||||
where
|
||||
TimedMessagesPreference {ttl} = userPreference.preference
|
||||
TimedMessagesPreference {ttl} = userPreference.preference
|
||||
|
||||
groupTimedTTL :: GroupInfo -> Maybe (Maybe Int)
|
||||
groupTimedTTL GroupInfo {fullGroupPreferences = FullGroupPreferences {timedMessages = TimedMessagesGroupPreference {enable, ttl}}}
|
||||
|
|
|
@ -311,7 +311,7 @@ profileToText Profile {displayName, fullName} = displayName <> optionalFullName
|
|||
msgIntegrityError :: MsgErrorType -> Text
|
||||
msgIntegrityError = \case
|
||||
MsgSkipped fromId toId ->
|
||||
"skipped message ID " <> tshow fromId
|
||||
("skipped message ID " <> tshow fromId)
|
||||
<> if fromId == toId then "" else ".." <> tshow toId
|
||||
MsgBadId msgId -> "unexpected message ID " <> tshow msgId
|
||||
MsgBadHash -> "incorrect message hash"
|
||||
|
|
|
@ -46,9 +46,9 @@ data SndConnEvent
|
|||
| SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef}
|
||||
deriving (Show)
|
||||
|
||||
data RcvDirectEvent =
|
||||
-- RDEProfileChanged {...}
|
||||
RDEContactDeleted
|
||||
data RcvDirectEvent
|
||||
= -- RDEProfileChanged {...}
|
||||
RDEContactDeleted
|
||||
deriving (Show)
|
||||
|
||||
-- platform-specific JSON encoding (used in API)
|
||||
|
|
|
@ -4,13 +4,12 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
{-# OPTIONS_GHC -fobject-code #-}
|
||||
|
||||
module Simplex.Chat.Mobile where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception (catch, SomeException)
|
||||
import Control.Exception (SomeException, catch)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import qualified Data.Aeson as J
|
||||
|
@ -31,7 +30,7 @@ import Foreign.C.Types (CInt (..))
|
|||
import Foreign.Ptr
|
||||
import Foreign.StablePtr
|
||||
import Foreign.Storable (poke)
|
||||
import GHC.IO.Encoding (setLocaleEncoding, setFileSystemEncoding, setForeignEncoding)
|
||||
import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding)
|
||||
import Simplex.Chat
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
|
||||
|
@ -219,7 +218,7 @@ chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do
|
|||
ExceptT $
|
||||
(first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey confirmMigrations)
|
||||
`catch` (pure . checkDBError)
|
||||
`catchAll` (pure . dbError)
|
||||
`catchAll` (pure . dbError)
|
||||
where
|
||||
checkDBError e = case sqlError e of
|
||||
DB.ErrorNotADatabase -> Left $ DBMErrorNotADatabase dbFile
|
||||
|
@ -233,7 +232,7 @@ chatCloseStore ChatController {chatStore, smpAgent} = handleErr $ do
|
|||
|
||||
handleErr :: IO () -> IO String
|
||||
handleErr a = (a $> "") `catch` (pure . show @SomeException)
|
||||
|
||||
|
||||
chatSendCmd :: ChatController -> B.ByteString -> IO JSONByteString
|
||||
chatSendCmd cc = chatSendRemoteCmd cc Nothing
|
||||
|
||||
|
|
|
@ -6,8 +6,8 @@ import qualified Data.ByteString as B
|
|||
import Data.ByteString.Internal (ByteString (..), memcpy)
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import qualified Data.ByteString.Lazy.Internal as LB
|
||||
import Foreign.C (CInt, CString)
|
||||
import Foreign
|
||||
import Foreign.C (CInt, CString)
|
||||
|
||||
type CJSONString = CString
|
||||
|
||||
|
|
|
@ -1,12 +1,12 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module Simplex.Chat.Mobile.WebRTC (
|
||||
cChatEncryptMedia,
|
||||
cChatDecryptMedia,
|
||||
chatEncryptMedia,
|
||||
chatDecryptMedia,
|
||||
reservedSize,
|
||||
) where
|
||||
module Simplex.Chat.Mobile.WebRTC
|
||||
( cChatEncryptMedia,
|
||||
cChatDecryptMedia,
|
||||
chatEncryptMedia,
|
||||
chatDecryptMedia,
|
||||
reservedSize,
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
|
@ -21,8 +21,8 @@ import Data.Either (fromLeft)
|
|||
import Data.Word (Word8)
|
||||
import Foreign.C (CInt, CString, newCAString)
|
||||
import Foreign.Ptr (Ptr)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Chat.Mobile.Shared
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
|
||||
cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
|
||||
cChatEncryptMedia = cTransformMedia chatEncryptMedia
|
||||
|
|
|
@ -18,10 +18,10 @@ generateRandomProfile = do
|
|||
pickNoun adjective n
|
||||
| n == 0 = pick nouns
|
||||
| otherwise = do
|
||||
noun <- pick nouns
|
||||
if noun == adjective
|
||||
then pickNoun adjective (n - 1)
|
||||
else pure noun
|
||||
noun <- pick nouns
|
||||
if noun == adjective
|
||||
then pickNoun adjective (n - 1)
|
||||
else pure noun
|
||||
|
||||
adjectives :: [Text]
|
||||
adjectives =
|
||||
|
|
|
@ -13,7 +13,6 @@
|
|||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Chat.Protocol where
|
||||
|
|
|
@ -97,24 +97,26 @@ discoveryTimeout = 60000000
|
|||
getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient
|
||||
getRemoteHostClient rhId = do
|
||||
sessions <- asks remoteHostSessions
|
||||
liftIOEither . atomically $ TM.lookup rhKey sessions >>= \case
|
||||
Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient
|
||||
Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
|
||||
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
|
||||
liftIOEither . atomically $
|
||||
TM.lookup rhKey sessions >>= \case
|
||||
Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient
|
||||
Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
|
||||
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
|
||||
where
|
||||
rhKey = RHId rhId
|
||||
|
||||
withRemoteHostSession :: ChatMonad m => RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> m a
|
||||
withRemoteHostSession rhKey sseq f = do
|
||||
sessions <- asks remoteHostSessions
|
||||
r <- atomically $
|
||||
TM.lookup rhKey sessions >>= \case
|
||||
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
|
||||
Just (stateSeq, state)
|
||||
| stateSeq /= sseq -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
|
||||
| otherwise -> case f state of
|
||||
Right (r, newState) -> Right r <$ TM.insert rhKey (sseq, newState) sessions
|
||||
Left ce -> pure $ Left ce
|
||||
r <-
|
||||
atomically $
|
||||
TM.lookup rhKey sessions >>= \case
|
||||
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
|
||||
Just (stateSeq, state)
|
||||
| stateSeq /= sseq -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
|
||||
| otherwise -> case f state of
|
||||
Right (r, newState) -> Right r <$ TM.insert rhKey (sseq, newState) sessions
|
||||
Left ce -> pure $ Left ce
|
||||
liftEither r
|
||||
|
||||
-- | Transition session state with a 'RHNew' ID to an assigned 'RemoteHostId'
|
||||
|
@ -167,14 +169,16 @@ startRemoteHost rh_ = do
|
|||
when (encoding == PEKotlin && localEncoding == PESwift) $ throwError $ RHEProtocolError RPEIncompatibleEncoding
|
||||
pure hostInfo
|
||||
handleConnectError :: ChatMonad m => RHKey -> SessionSeq -> m a -> m a
|
||||
handleConnectError rhKey sessSeq action = action `catchChatError` \err -> do
|
||||
logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err
|
||||
cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey
|
||||
throwError err
|
||||
handleConnectError rhKey sessSeq action =
|
||||
action `catchChatError` \err -> do
|
||||
logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err
|
||||
cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey
|
||||
throwError err
|
||||
handleHostError :: ChatMonad m => SessionSeq -> TVar RHKey -> m () -> m ()
|
||||
handleHostError sessSeq rhKeyVar action = action `catchChatError` \err -> do
|
||||
logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err
|
||||
readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err))
|
||||
handleHostError sessSeq rhKeyVar action =
|
||||
action `catchChatError` \err -> do
|
||||
logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow 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 remoteHost_ rhKey sseq rhKeyVar vars = do
|
||||
(sessId, tls, vars') <- timeoutThrow (ChatErrorRemoteHost rhKey RHETimeout) 60000000 $ takeRCStep vars
|
||||
|
@ -250,14 +254,15 @@ cancelRemoteHostSession :: ChatMonad m => Maybe (SessionSeq, RemoteHostStopReaso
|
|||
cancelRemoteHostSession handlerInfo_ rhKey = do
|
||||
sessions <- asks remoteHostSessions
|
||||
crh <- asks currentRemoteHost
|
||||
deregistered <- atomically $
|
||||
TM.lookup rhKey sessions >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler
|
||||
Just (_, rhs) -> do
|
||||
TM.delete rhKey sessions
|
||||
modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH
|
||||
pure $ Just rhs
|
||||
deregistered <-
|
||||
atomically $
|
||||
TM.lookup rhKey sessions >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler
|
||||
Just (_, rhs) -> do
|
||||
TM.delete rhKey sessions
|
||||
modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH
|
||||
pure $ Just rhs
|
||||
forM_ deregistered $ \session -> do
|
||||
liftIO $ cancelRemoteHost handlingError session `catchAny` (logError . tshow)
|
||||
forM_ (snd <$> handlerInfo_) $ \rhStopReason ->
|
||||
|
@ -401,9 +406,10 @@ findKnownRemoteCtrl = do
|
|||
(RCCtrlPairing {ctrlFingerprint}, inv@(RCVerifiedInvitation RCInvitation {app})) <-
|
||||
timeoutThrow (ChatErrorRemoteCtrl RCETimeout) discoveryTimeout . withAgent $ \a -> rcDiscoverCtrl a pairings
|
||||
ctrlAppInfo_ <- (Just <$> parseCtrlAppInfo app) `catchChatError` const (pure Nothing)
|
||||
rc <- withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case
|
||||
Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl"
|
||||
Just rc -> pure rc
|
||||
rc <-
|
||||
withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case
|
||||
Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl"
|
||||
Just rc -> pure rc
|
||||
atomically $ putTMVar foundCtrl (rc, inv)
|
||||
let compatible = isJust $ compatibleAppVersion hostAppVersionRange . appVersionRange =<< ctrlAppInfo_
|
||||
toView CRRemoteCtrlFound {remoteCtrl = remoteCtrlInfo rc (Just RCSSearching), ctrlAppInfo_, appVersion = currentAppVersion, compatible}
|
||||
|
@ -422,7 +428,7 @@ confirmRemoteCtrl rcId = do
|
|||
pure $ Right (sseq, action, foundCtrl)
|
||||
_ -> pure . Left $ ChatErrorRemoteCtrl RCEBadState
|
||||
uninterruptibleCancel listener
|
||||
(RemoteCtrl{remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found
|
||||
(RemoteCtrl {remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found
|
||||
unless (rcId == foundRcId) $ throwError $ ChatErrorRemoteCtrl RCEBadController
|
||||
connectRemoteCtrl verifiedInv sseq >>= \case
|
||||
(Nothing, _) -> throwChatError $ CEInternalError "connecting with a stored ctrl"
|
||||
|
@ -647,10 +653,12 @@ handleCtrlError sseq mkReason name action =
|
|||
cancelActiveRemoteCtrl :: ChatMonad m => Maybe (SessionSeq, RemoteCtrlStopReason) -> m ()
|
||||
cancelActiveRemoteCtrl handlerInfo_ = handleAny (logError . tshow) $ do
|
||||
var <- asks remoteCtrlSession
|
||||
session_ <- atomically $ readTVar var >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just (oldSeq, _) | maybe False (/= oldSeq) (fst <$> handlerInfo_) -> pure Nothing
|
||||
Just (_, s) -> Just s <$ writeTVar var Nothing
|
||||
session_ <-
|
||||
atomically $
|
||||
readTVar var >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just (oldSeq, _) | (maybe False ((oldSeq /=) . fst) handlerInfo_) -> pure Nothing
|
||||
Just (_, s) -> Just s <$ writeTVar var Nothing
|
||||
forM_ session_ $ \session -> do
|
||||
liftIO $ cancelRemoteCtrl handlingError session
|
||||
forM_ (snd <$> handlerInfo_) $ \rcStopReason ->
|
||||
|
|
|
@ -11,7 +11,7 @@ module Simplex.Chat.Remote.AppVersion
|
|||
compatibleAppVersion,
|
||||
isAppCompatible,
|
||||
)
|
||||
where
|
||||
where
|
||||
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson as J
|
||||
|
|
|
@ -6,10 +6,8 @@ import Network.Socket
|
|||
|
||||
#include <HsNet.h>
|
||||
|
||||
{- | Toggle multicast group membership.
|
||||
|
||||
NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups.
|
||||
-}
|
||||
-- | Toggle multicast group membership.
|
||||
-- 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 sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do
|
||||
#{poke struct ip_mreq, imr_multiaddr} mReqPtr group
|
||||
|
|
|
@ -6,8 +6,8 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.Chat.Remote.Protocol where
|
||||
|
||||
|
@ -41,16 +41,16 @@ import Simplex.FileTransfer.Description (FileDigest (..))
|
|||
import Simplex.Messaging.Agent.Client (agentDRG)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..))
|
||||
import Simplex.Messaging.Crypto.Lazy (LazyByteString)
|
||||
import Simplex.Messaging.Crypto.Lazy (LazyByteString)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON, pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag)
|
||||
import Simplex.Messaging.Transport.Buffer (getBuffered)
|
||||
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk)
|
||||
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect)
|
||||
import Simplex.Messaging.Util (liftEitherError, liftEitherWith, liftError, tshow)
|
||||
import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode)
|
||||
import Simplex.RemoteControl.Client (xrcpBlockSize)
|
||||
import qualified Simplex.RemoteControl.Client as RC
|
||||
import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode)
|
||||
import System.FilePath (takeFileName, (</>))
|
||||
import UnliftIO
|
||||
|
||||
|
@ -64,10 +64,10 @@ data RemoteCommand
|
|||
|
||||
data RemoteResponse
|
||||
= RRChatResponse {chatResponse :: ChatResponse}
|
||||
| RRChatEvent {chatEvent :: Maybe ChatResponse} -- ^ 'Nothing' on poll timeout
|
||||
| RRChatEvent {chatEvent :: Maybe ChatResponse} -- 'Nothing' on poll timeout
|
||||
| RRFileStored {filePath :: String}
|
||||
| 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)
|
||||
|
||||
-- Force platform-independent encoding as the types aren't UI-visible
|
||||
|
@ -126,7 +126,7 @@ remoteStoreFile c localPath fileName = do
|
|||
r -> badResponse r
|
||||
|
||||
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
|
||||
(getChunk, RRFile {fileSize, fileDigest}) -> do
|
||||
-- TODO we could optimize by checking size and hash before receiving the file
|
||||
|
@ -140,7 +140,7 @@ sendRemoteCommand' c attachment_ rc = snd <$> sendRemoteCommand c attachment_ rc
|
|||
|
||||
sendRemoteCommand :: RemoteHostClient -> Maybe (Handle, Word32) -> RemoteCommand -> ExceptT RemoteProtocolError IO (Int -> IO ByteString, RemoteResponse)
|
||||
sendRemoteCommand RemoteHostClient {httpClient, hostEncoding, encryption} file_ cmd = do
|
||||
encFile_ <- mapM (prepareEncryptedFile encryption) file_
|
||||
encFile_ <- mapM (prepareEncryptedFile encryption) file_
|
||||
req <- httpRequest encFile_ <$> encryptEncodeHTTP2Body encryption (J.encode cmd)
|
||||
HTTP2Response {response, respBody} <- liftEitherError (RPEHTTP2 . tshow) $ sendRequestDirect httpClient req Nothing
|
||||
(header, getNext) <- parseDecryptHTTP2Body encryption response respBody
|
||||
|
|
|
@ -5,15 +5,15 @@ module Simplex.Chat.Remote.Transport where
|
|||
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Data.ByteString.Builder (Builder, byteString)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString.Builder (Builder, byteString)
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Word (Word32)
|
||||
import Simplex.FileTransfer.Description (FileDigest (..))
|
||||
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.Lazy as LC
|
||||
import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sendEncFile)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Util (liftEitherError, liftEitherWith)
|
||||
import Simplex.RemoteControl.Types (RCErrorType (..))
|
||||
|
|
|
@ -21,13 +21,13 @@ import Data.Text (Text)
|
|||
import Simplex.Chat.Remote.AppVersion
|
||||
import Simplex.Chat.Types (verificationCode)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile)
|
||||
import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret)
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
|
||||
import Simplex.Messaging.Transport (TLS (..))
|
||||
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
|
||||
import Simplex.RemoteControl.Client
|
||||
import Simplex.RemoteControl.Types
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile)
|
||||
import Simplex.Messaging.Transport (TLS (..))
|
||||
|
||||
data RemoteHostClient = RemoteHostClient
|
||||
{ hostEncoding :: PlatformEncoding,
|
||||
|
@ -48,13 +48,13 @@ data RemoteCrypto = RemoteCrypto
|
|||
|
||||
data RemoteSignatures
|
||||
= RSSign
|
||||
{ idPrivKey :: C.PrivateKeyEd25519,
|
||||
sessPrivKey :: C.PrivateKeyEd25519
|
||||
}
|
||||
{ idPrivKey :: C.PrivateKeyEd25519,
|
||||
sessPrivKey :: C.PrivateKeyEd25519
|
||||
}
|
||||
| RSVerify
|
||||
{ idPubKey :: C.PublicKeyEd25519,
|
||||
sessPubKey :: C.PublicKeyEd25519
|
||||
}
|
||||
{ idPubKey :: C.PublicKeyEd25519,
|
||||
sessPubKey :: C.PublicKeyEd25519
|
||||
}
|
||||
|
||||
type SessionSeq = Int
|
||||
|
||||
|
@ -71,12 +71,12 @@ data RemoteHostSession
|
|||
| RHSessionPendingConfirmation {sessionCode :: Text, tls :: TLS, rhPendingSession :: RHPendingSession}
|
||||
| RHSessionConfirmed {tls :: TLS, rhPendingSession :: RHPendingSession}
|
||||
| RHSessionConnected
|
||||
{ rchClient :: RCHostClient,
|
||||
tls :: TLS,
|
||||
rhClient :: RemoteHostClient,
|
||||
pollAction :: Async (),
|
||||
storePath :: FilePath
|
||||
}
|
||||
{ rchClient :: RCHostClient,
|
||||
tls :: TLS,
|
||||
rhClient :: RemoteHostClient,
|
||||
pollAction :: Async (),
|
||||
storePath :: FilePath
|
||||
}
|
||||
|
||||
data RemoteHostSessionState
|
||||
= RHSStarting
|
||||
|
|
|
@ -4,7 +4,6 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Chat.Store.Connections
|
||||
|
@ -25,11 +24,11 @@ import Data.Text (Text)
|
|||
import Data.Time.Clock (UTCTime (..))
|
||||
import Database.SQLite.Simple (Only (..), (:.) (..))
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Store.Files
|
||||
import Simplex.Chat.Store.Groups
|
||||
import Simplex.Chat.Store.Profiles
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId)
|
||||
|
@ -157,8 +156,9 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
|
|||
|
||||
getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
|
||||
getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||
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)
|
||||
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)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
|
||||
|
||||
-- search connection for connection plan:
|
||||
|
@ -167,21 +167,22 @@ getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) =
|
|||
-- deleted connections are filtered out to allow re-connecting via same contact address
|
||||
getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
|
||||
getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do
|
||||
connId_ <- maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT agent_conn_id FROM (
|
||||
SELECT
|
||||
agent_conn_id,
|
||||
(CASE WHEN contact_id IS NOT NULL THEN 1 ELSE 0 END) AS conn_ord
|
||||
FROM connections
|
||||
WHERE user_id = ? AND via_contact_uri_hash IN (?,?) AND conn_status != ?
|
||||
ORDER BY conn_ord DESC, created_at DESC
|
||||
LIMIT 1
|
||||
)
|
||||
|]
|
||||
(userId, cReqHash1, cReqHash2, ConnDeleted)
|
||||
connId_ <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT agent_conn_id FROM (
|
||||
SELECT
|
||||
agent_conn_id,
|
||||
(CASE WHEN contact_id IS NOT NULL THEN 1 ELSE 0 END) AS conn_ord
|
||||
FROM connections
|
||||
WHERE user_id = ? AND via_contact_uri_hash IN (?,?) AND conn_status != ?
|
||||
ORDER BY conn_ord DESC, created_at DESC
|
||||
LIMIT 1
|
||||
)
|
||||
|]
|
||||
(userId, cReqHash1, cReqHash2, ConnDeleted)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
|
||||
|
||||
getConnectionsToSubscribe :: DB.Connection -> IO ([ConnId], [ConnectionEntity])
|
||||
|
|
|
@ -1,13 +1,12 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Chat.Store.Direct
|
||||
|
@ -310,14 +309,14 @@ deleteUnusedProfile_ db userId profileId =
|
|||
updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact
|
||||
updateContactProfile db user@User {userId} c p'
|
||||
| displayName == newName = do
|
||||
liftIO $ updateContactProfile_ db userId profileId p'
|
||||
pure c {profile, mergedPreferences}
|
||||
liftIO $ updateContactProfile_ db userId profileId p'
|
||||
pure c {profile, mergedPreferences}
|
||||
| otherwise =
|
||||
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
|
||||
currentTs <- getCurrentTime
|
||||
updateContactProfile_' db userId profileId p' currentTs
|
||||
updateContact_ db userId contactId localDisplayName ldn currentTs
|
||||
pure $ Right c {localDisplayName = ldn, profile, mergedPreferences}
|
||||
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
|
||||
currentTs <- getCurrentTime
|
||||
updateContactProfile_' db userId profileId p' currentTs
|
||||
updateContact_ db userId contactId localDisplayName ldn currentTs
|
||||
pure $ Right c {localDisplayName = ldn, profile, mergedPreferences}
|
||||
where
|
||||
Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, userPreferences} = c
|
||||
Profile {displayName = newName, preferences} = p'
|
||||
|
@ -784,10 +783,8 @@ updateConnectionStatus :: DB.Connection -> Connection -> ConnStatus -> IO ()
|
|||
updateConnectionStatus db Connection {connId} connStatus = do
|
||||
currentTs <- getCurrentTime
|
||||
if connStatus == ConnReady
|
||||
then
|
||||
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)
|
||||
then 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)
|
||||
|
||||
updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO ()
|
||||
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 = ?
|
||||
|]
|
||||
(updatedAt, userId, connId)
|
||||
|
||||
|
|
|
@ -109,7 +109,7 @@ import Simplex.Messaging.Protocol (SubscriptionMode (..))
|
|||
|
||||
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
|
||||
getLiveSndFileTransfers db User {userId} = do
|
||||
cutoffTs <- addUTCTime (- week) <$> getCurrentTime
|
||||
cutoffTs <- addUTCTime (-week) <$> getCurrentTime
|
||||
fileIds :: [Int64] <-
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
|
@ -132,7 +132,7 @@ getLiveSndFileTransfers db User {userId} = do
|
|||
|
||||
getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer]
|
||||
getLiveRcvFileTransfers db user@User {userId} = do
|
||||
cutoffTs <- addUTCTime (- week) <$> getCurrentTime
|
||||
cutoffTs <- addUTCTime (-week) <$> getCurrentTime
|
||||
fileIds :: [Int64] <-
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
|
@ -234,11 +234,12 @@ createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Conn
|
|||
|
||||
updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> ExceptT StoreError IO ()
|
||||
updateSndDirectFTDelivery _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
|
||||
updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = liftIO $
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
|
||||
(msgDeliveryId, connId, fileId)
|
||||
updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId =
|
||||
liftIO $
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
|
||||
(msgDeliveryId, connId, fileId)
|
||||
|
||||
updateSndGroupFTDelivery :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> Int64 -> IO ()
|
||||
updateSndGroupFTDelivery db GroupMember {groupMemberId} Connection {connId} FileTransferMeta {fileId} msgDeliveryId =
|
||||
|
@ -724,7 +725,7 @@ removeFileCryptoArgs db fileId = do
|
|||
|
||||
getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer]
|
||||
getRcvFilesToReceive db user@User {userId} = do
|
||||
cutoffTs <- addUTCTime (- (2 * nominalDay)) <$> getCurrentTime
|
||||
cutoffTs <- addUTCTime (-(2 * nominalDay)) <$> getCurrentTime
|
||||
fileIds :: [Int64] <-
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
|
@ -768,20 +769,20 @@ createRcvFileChunk db RcvFileTransfer {fileId, fileInvitation = FileInvitation {
|
|||
pure $ case map fromOnly ns of
|
||||
[]
|
||||
| chunkNo == 1 ->
|
||||
if chunkSize >= fileSize
|
||||
then RcvChunkFinal
|
||||
else RcvChunkOk
|
||||
if chunkSize >= fileSize
|
||||
then RcvChunkFinal
|
||||
else RcvChunkOk
|
||||
| otherwise -> RcvChunkError
|
||||
n : _
|
||||
| chunkNo == n -> RcvChunkDuplicate
|
||||
| chunkNo == n + 1 ->
|
||||
let prevSize = n * chunkSize
|
||||
in if prevSize >= fileSize
|
||||
then RcvChunkError
|
||||
else
|
||||
if prevSize + chunkSize >= fileSize
|
||||
then RcvChunkFinal
|
||||
else RcvChunkOk
|
||||
let prevSize = n * chunkSize
|
||||
in if prevSize >= fileSize
|
||||
then RcvChunkError
|
||||
else
|
||||
if prevSize + chunkSize >= fileSize
|
||||
then RcvChunkFinal
|
||||
else RcvChunkOk
|
||||
| otherwise -> RcvChunkError
|
||||
|
||||
updatedRcvFileChunkStored :: DB.Connection -> RcvFileTransfer -> Integer -> IO ()
|
||||
|
|
|
@ -2,14 +2,13 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Chat.Store.Groups
|
||||
|
@ -122,7 +121,7 @@ import Crypto.Random (ChaChaDRG)
|
|||
import Data.Either (rights)
|
||||
import Data.Int (Int64)
|
||||
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.Text (Text)
|
||||
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||||
|
@ -446,39 +445,39 @@ createGroupInvitedViaLink
|
|||
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs supportedChatVRange
|
||||
liftIO $ setViaGroupLinkHash db groupId connId
|
||||
(,) <$> getGroupInfo db user groupId <*> getGroupMemberById db user hostMemberId
|
||||
where
|
||||
insertGroup_ currentTs = ExceptT $ do
|
||||
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile
|
||||
withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do
|
||||
liftIO $ do
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
|
||||
(displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs)
|
||||
profileId <- insertedRowId db
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO groups (group_profile_id, local_display_name, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?)"
|
||||
(profileId, localDisplayName, customUserProfileId, userId, True, currentTs, currentTs, currentTs)
|
||||
insertedRowId db
|
||||
insertHost_ currentTs groupId = ExceptT $ do
|
||||
let fromMemberProfile = profileFromName fromMemberName
|
||||
withLocalDisplayName db userId fromMemberName $ \localDisplayName -> runExceptT $ do
|
||||
(_, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs
|
||||
let MemberIdRole {memberId, memberRole} = fromMember
|
||||
liftIO $ do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO group_members
|
||||
( group_id, member_id, member_role, member_category, member_status, invited_by,
|
||||
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
( (groupId, memberId, memberRole, GCHostMember, GSMemAccepted, fromInvitedBy userContactId IBUnknown)
|
||||
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs)
|
||||
)
|
||||
insertedRowId db
|
||||
where
|
||||
insertGroup_ currentTs = ExceptT $ do
|
||||
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile
|
||||
withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do
|
||||
liftIO $ do
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
|
||||
(displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs)
|
||||
profileId <- insertedRowId db
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO groups (group_profile_id, local_display_name, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?)"
|
||||
(profileId, localDisplayName, customUserProfileId, userId, True, currentTs, currentTs, currentTs)
|
||||
insertedRowId db
|
||||
insertHost_ currentTs groupId = ExceptT $ do
|
||||
let fromMemberProfile = profileFromName fromMemberName
|
||||
withLocalDisplayName db userId fromMemberName $ \localDisplayName -> runExceptT $ do
|
||||
(_, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs
|
||||
let MemberIdRole {memberId, memberRole} = fromMember
|
||||
liftIO $ do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO group_members
|
||||
( group_id, member_id, member_role, member_category, member_status, invited_by,
|
||||
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
( (groupId, memberId, memberRole, GCHostMember, GSMemAccepted, fromInvitedBy userContactId IBUnknown)
|
||||
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs)
|
||||
)
|
||||
insertedRowId db
|
||||
|
||||
setViaGroupLinkHash :: DB.Connection -> GroupId -> Int64 -> IO ()
|
||||
setViaGroupLinkHash db groupId connId =
|
||||
|
@ -814,22 +813,22 @@ createAcceptedMember
|
|||
insertMember_ (MemberId memId) createdAt
|
||||
groupMemberId <- liftIO $ insertedRowId db
|
||||
pure (groupMemberId, MemberId memId)
|
||||
where
|
||||
JVersionRange (VersionRange minV maxV) = cReqChatVRange
|
||||
insertMember_ memberId createdAt =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO group_members
|
||||
( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id,
|
||||
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at,
|
||||
peer_chat_min_version, peer_chat_max_version)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
( (groupId, memberId, memberRole, GCInviteeMember, GSMemAccepted, fromInvitedBy userContactId IBUser, groupMemberId' membership)
|
||||
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, createdAt, createdAt)
|
||||
:. (minV, maxV)
|
||||
)
|
||||
where
|
||||
JVersionRange (VersionRange minV maxV) = cReqChatVRange
|
||||
insertMember_ memberId createdAt =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO group_members
|
||||
( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id,
|
||||
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at,
|
||||
peer_chat_min_version, peer_chat_max_version)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
( (groupId, memberId, memberRole, GCInviteeMember, GSMemAccepted, fromInvitedBy userContactId IBUser, groupMemberId' membership)
|
||||
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, createdAt, createdAt)
|
||||
:. (minV, maxV)
|
||||
)
|
||||
|
||||
createAcceptedMemberConnection :: DB.Connection -> User -> (CommandId, ConnId) -> UserContactRequest -> GroupMemberId -> SubscriptionMode -> IO ()
|
||||
createAcceptedMemberConnection
|
||||
|
@ -957,23 +956,24 @@ createNewMember_
|
|||
:. (minV, maxV)
|
||||
)
|
||||
groupMemberId <- insertedRowId db
|
||||
pure GroupMember {
|
||||
groupMemberId,
|
||||
groupId,
|
||||
memberId,
|
||||
memberRole,
|
||||
memberCategory,
|
||||
memberStatus,
|
||||
memberSettings = defaultMemberSettings,
|
||||
invitedBy,
|
||||
invitedByGroupMemberId = memInvitedByGroupMemberId,
|
||||
localDisplayName,
|
||||
memberProfile = toLocalProfile memberContactProfileId memberProfile "",
|
||||
memberContactId,
|
||||
memberContactProfileId,
|
||||
activeConn,
|
||||
memberChatVRange = JVersionRange mcvr
|
||||
}
|
||||
pure
|
||||
GroupMember
|
||||
{ groupMemberId,
|
||||
groupId,
|
||||
memberId,
|
||||
memberRole,
|
||||
memberCategory,
|
||||
memberStatus,
|
||||
memberSettings = defaultMemberSettings,
|
||||
invitedBy,
|
||||
invitedByGroupMemberId = memInvitedByGroupMemberId,
|
||||
localDisplayName,
|
||||
memberProfile = toLocalProfile memberContactProfileId memberProfile "",
|
||||
memberContactId,
|
||||
memberContactProfileId,
|
||||
activeConn,
|
||||
memberChatVRange = JVersionRange mcvr
|
||||
}
|
||||
|
||||
checkGroupMemberHasItems :: DB.Connection -> User -> GroupMember -> IO (Maybe ChatItemId)
|
||||
checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} =
|
||||
|
@ -1104,41 +1104,41 @@ getForwardIntroducedMembers :: DB.Connection -> User -> GroupMember -> Bool -> I
|
|||
getForwardIntroducedMembers db user invitee highlyAvailable = do
|
||||
memberIds <- map fromOnly <$> query
|
||||
filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds
|
||||
where
|
||||
mId = groupMemberId' invitee
|
||||
query
|
||||
| highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected)
|
||||
| otherwise =
|
||||
DB.query
|
||||
db
|
||||
(q <> " AND intro_chat_protocol_version >= ?")
|
||||
(mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange)
|
||||
q =
|
||||
[sql|
|
||||
SELECT re_group_member_id
|
||||
FROM group_member_intros
|
||||
WHERE to_group_member_id = ? AND intro_status NOT IN (?,?,?)
|
||||
|]
|
||||
where
|
||||
mId = groupMemberId' invitee
|
||||
query
|
||||
| highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected)
|
||||
| otherwise =
|
||||
DB.query
|
||||
db
|
||||
(q <> " AND intro_chat_protocol_version >= ?")
|
||||
(mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange)
|
||||
q =
|
||||
[sql|
|
||||
SELECT re_group_member_id
|
||||
FROM group_member_intros
|
||||
WHERE to_group_member_id = ? AND intro_status NOT IN (?,?,?)
|
||||
|]
|
||||
|
||||
getForwardInvitedMembers :: DB.Connection -> User -> GroupMember -> Bool -> IO [GroupMember]
|
||||
getForwardInvitedMembers db user forwardMember highlyAvailable = do
|
||||
memberIds <- map fromOnly <$> query
|
||||
filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds
|
||||
where
|
||||
mId = groupMemberId' forwardMember
|
||||
query
|
||||
| highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected)
|
||||
| otherwise =
|
||||
DB.query
|
||||
db
|
||||
(q <> " AND intro_chat_protocol_version >= ?")
|
||||
(mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange)
|
||||
q =
|
||||
[sql|
|
||||
SELECT to_group_member_id
|
||||
FROM group_member_intros
|
||||
WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?)
|
||||
|]
|
||||
where
|
||||
mId = groupMemberId' forwardMember
|
||||
query
|
||||
| highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected)
|
||||
| otherwise =
|
||||
DB.query
|
||||
db
|
||||
(q <> " AND intro_chat_protocol_version >= ?")
|
||||
(mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange)
|
||||
q =
|
||||
[sql|
|
||||
SELECT to_group_member_id
|
||||
FROM group_member_intros
|
||||
WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?)
|
||||
|]
|
||||
|
||||
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember
|
||||
createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do
|
||||
|
@ -1263,15 +1263,15 @@ getViaGroupContact db user@User {userId} GroupMember {groupMemberId} = do
|
|||
updateGroupProfile :: DB.Connection -> User -> GroupInfo -> GroupProfile -> ExceptT StoreError IO GroupInfo
|
||||
updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, description, image, groupPreferences}
|
||||
| displayName == newName = liftIO $ do
|
||||
currentTs <- getCurrentTime
|
||||
updateGroupProfile_ currentTs
|
||||
pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences}
|
||||
| otherwise =
|
||||
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
|
||||
currentTs <- getCurrentTime
|
||||
updateGroupProfile_ currentTs
|
||||
updateGroup_ ldn currentTs
|
||||
pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences}
|
||||
pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences}
|
||||
| otherwise =
|
||||
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
|
||||
currentTs <- getCurrentTime
|
||||
updateGroupProfile_ currentTs
|
||||
updateGroup_ ldn currentTs
|
||||
pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences}
|
||||
where
|
||||
fullGroupPreferences = mergeGroupPreferences groupPreferences
|
||||
updateGroupProfile_ currentTs =
|
||||
|
@ -1317,31 +1317,33 @@ getGroupInfo db User {userId, userContactId} groupId =
|
|||
|
||||
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
|
||||
getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||
groupId_ <- maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT group_id
|
||||
FROM user_contact_links
|
||||
WHERE user_id = ? AND conn_req_contact IN (?,?)
|
||||
|]
|
||||
(userId, cReqSchema1, cReqSchema2)
|
||||
groupId_ <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT group_id
|
||||
FROM user_contact_links
|
||||
WHERE user_id = ? AND conn_req_contact IN (?,?)
|
||||
|]
|
||||
(userId, cReqSchema1, cReqSchema2)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
|
||||
|
||||
getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
|
||||
getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
|
||||
groupId_ <- maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT g.group_id
|
||||
FROM groups g
|
||||
JOIN group_members mu ON mu.group_id = g.group_id
|
||||
WHERE g.user_id = ? AND g.via_group_link_uri_hash IN (?,?)
|
||||
AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?)
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
|
||||
groupId_ <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT g.group_id
|
||||
FROM groups g
|
||||
JOIN group_members mu ON mu.group_id = g.group_id
|
||||
WHERE g.user_id = ? AND g.via_group_link_uri_hash IN (?,?)
|
||||
AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?)
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
|
||||
|
||||
getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId
|
||||
|
@ -1935,18 +1937,18 @@ createMemberContactConn_
|
|||
updateMemberProfile :: DB.Connection -> User -> GroupMember -> Profile -> ExceptT StoreError IO GroupMember
|
||||
updateMemberProfile db User {userId} m p'
|
||||
| displayName == newName = do
|
||||
liftIO $ updateContactProfile_ db userId profileId p'
|
||||
pure m {memberProfile = profile}
|
||||
liftIO $ updateContactProfile_ db userId profileId p'
|
||||
pure m {memberProfile = profile}
|
||||
| otherwise =
|
||||
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
|
||||
currentTs <- getCurrentTime
|
||||
updateContactProfile_' db userId profileId p' currentTs
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?"
|
||||
(ldn, currentTs, userId, groupMemberId)
|
||||
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId)
|
||||
pure $ Right m {localDisplayName = ldn, memberProfile = profile}
|
||||
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
|
||||
currentTs <- getCurrentTime
|
||||
updateContactProfile_' db userId profileId p' currentTs
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?"
|
||||
(ldn, currentTs, userId, groupMemberId)
|
||||
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId)
|
||||
pure $ Right m {localDisplayName = ldn, memberProfile = profile}
|
||||
where
|
||||
GroupMember {groupMemberId, localDisplayName, memberProfile = LocalProfile {profileId, displayName, localAlias}} = m
|
||||
Profile {displayName = newName} = p'
|
||||
|
|
|
@ -10,7 +10,6 @@
|
|||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Chat.Store.Messages
|
||||
|
@ -199,40 +198,41 @@ createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMs
|
|||
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs
|
||||
pure msg
|
||||
|
||||
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 :: 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 =
|
||||
case connOrGroupId of
|
||||
ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing
|
||||
GroupId groupId -> case sharedMsgId_ of
|
||||
Just sharedMsgId -> liftIO (duplicateGroupMsgMemberIds groupId sharedMsgId) >>= \case
|
||||
Just (duplAuthorId, duplFwdMemberId) ->
|
||||
throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId
|
||||
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
|
||||
Just sharedMsgId ->
|
||||
liftIO (duplicateGroupMsgMemberIds groupId sharedMsgId) >>= \case
|
||||
Just (duplAuthorId, duplFwdMemberId) ->
|
||||
throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId
|
||||
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
|
||||
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
|
||||
where
|
||||
duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId))
|
||||
duplicateGroupMsgMemberIds groupId sharedMsgId =
|
||||
maybeFirstRow id
|
||||
$ DB.query
|
||||
where
|
||||
duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId))
|
||||
duplicateGroupMsgMemberIds groupId sharedMsgId =
|
||||
maybeFirstRow id $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT author_group_member_id, forwarded_by_group_member_id
|
||||
FROM messages
|
||||
WHERE group_id = ? AND shared_msg_id = ? LIMIT 1
|
||||
|]
|
||||
(groupId, sharedMsgId)
|
||||
insertRcvMsg connId_ groupId_ = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
SELECT author_group_member_id, forwarded_by_group_member_id
|
||||
FROM messages
|
||||
WHERE group_id = ? AND shared_msg_id = ? LIMIT 1
|
||||
INSERT INTO messages
|
||||
(msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
(groupId, sharedMsgId)
|
||||
insertRcvMsg connId_ groupId_ = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO messages
|
||||
(msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
(MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember)
|
||||
msgId <- insertedRowId db
|
||||
pure RcvMessage{msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember}
|
||||
(MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember)
|
||||
msgId <- insertedRowId db
|
||||
pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember}
|
||||
|
||||
createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO ()
|
||||
createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do
|
||||
|
@ -1802,22 +1802,22 @@ getDirectReactions db ct itemSharedMId sent =
|
|||
setDirectReaction :: DB.Connection -> Contact -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO ()
|
||||
setDirectReaction db ct itemSharedMId sent reaction add msgId reactionTs
|
||||
| add =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO chat_item_reactions
|
||||
(contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts)
|
||||
VALUES (?,?,?,?,?,?)
|
||||
|]
|
||||
(contactId' ct, itemSharedMId, sent, reaction, msgId, reactionTs)
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO chat_item_reactions
|
||||
(contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts)
|
||||
VALUES (?,?,?,?,?,?)
|
||||
|]
|
||||
(contactId' ct, itemSharedMId, sent, reaction, msgId, reactionTs)
|
||||
| otherwise =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM chat_item_reactions
|
||||
WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ?
|
||||
|]
|
||||
(contactId' ct, itemSharedMId, sent, reaction)
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM chat_item_reactions
|
||||
WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ?
|
||||
|]
|
||||
(contactId' ct, itemSharedMId, sent, reaction)
|
||||
|
||||
getGroupReactions :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> IO [MsgReaction]
|
||||
getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent =
|
||||
|
@ -1834,22 +1834,22 @@ getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent =
|
|||
setGroupReaction :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO ()
|
||||
setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reaction add msgId reactionTs
|
||||
| add =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO chat_item_reactions
|
||||
(group_id, group_member_id, item_member_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts)
|
||||
VALUES (?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
(groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent, reaction, msgId, reactionTs)
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO chat_item_reactions
|
||||
(group_id, group_member_id, item_member_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts)
|
||||
VALUES (?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
(groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent, reaction, msgId, reactionTs)
|
||||
| otherwise =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM chat_item_reactions
|
||||
WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ?
|
||||
|]
|
||||
(groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction)
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM chat_item_reactions
|
||||
WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ?
|
||||
|]
|
||||
(groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction)
|
||||
|
||||
getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)]
|
||||
getTimedItems db User {userId} startTimedThreadCutoff =
|
||||
|
|
|
@ -8,7 +8,6 @@
|
|||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Chat.Store.Profiles
|
||||
|
@ -66,9 +65,9 @@ import Control.Monad.IO.Class
|
|||
import qualified Data.Aeson.TH as J
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||||
|
@ -89,7 +88,7 @@ import Simplex.Messaging.Encoding.String
|
|||
import Simplex.Messaging.Parsers (defaultJSON)
|
||||
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode)
|
||||
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 auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime
|
||||
|
@ -248,19 +247,19 @@ updateUserGroupReceipts db User {userId} UserMsgReceiptSettings {enable, clearOv
|
|||
updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User
|
||||
updateUserProfile db user p'
|
||||
| displayName == newName = do
|
||||
liftIO $ updateContactProfile_ db userId profileId p'
|
||||
pure user {profile, fullPreferences}
|
||||
liftIO $ updateContactProfile_ db userId profileId p'
|
||||
pure user {profile, fullPreferences}
|
||||
| otherwise =
|
||||
checkConstraint SEDuplicateName . liftIO $ do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId)
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
|
||||
(newName, newName, userId, currentTs, currentTs)
|
||||
updateContactProfile_' db userId profileId p' currentTs
|
||||
updateContact_ db userId userContactId localDisplayName newName currentTs
|
||||
pure user {localDisplayName = newName, profile, fullPreferences}
|
||||
checkConstraint SEDuplicateName . liftIO $ do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId)
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
|
||||
(newName, newName, userId, currentTs, currentTs)
|
||||
updateContactProfile_' db userId profileId p' currentTs
|
||||
updateContact_ db userId userContactId localDisplayName newName currentTs
|
||||
pure user {localDisplayName = newName, profile, fullPreferences}
|
||||
where
|
||||
User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}} = user
|
||||
Profile {displayName = newName, preferences} = p'
|
||||
|
@ -457,17 +456,18 @@ getUserContactLinkByConnReq db User {userId} (cReqSchema1, cReqSchema2) =
|
|||
|
||||
getContactWithoutConnViaAddress :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact)
|
||||
getContactWithoutConnViaAddress db user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||
ctId_ <- maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT ct.contact_id
|
||||
FROM contacts ct
|
||||
JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
|
||||
LEFT JOIN connections c ON c.contact_id = ct.contact_id
|
||||
WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL
|
||||
|]
|
||||
(userId, cReqSchema1, cReqSchema2)
|
||||
ctId_ <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT ct.contact_id
|
||||
FROM contacts ct
|
||||
JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
|
||||
LEFT JOIN connections c ON c.contact_id = ct.contact_id
|
||||
WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL
|
||||
|]
|
||||
(userId, cReqSchema1, cReqSchema2)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db user) ctId_
|
||||
|
||||
updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink
|
||||
|
|
|
@ -101,7 +101,7 @@ data StoreError
|
|||
| SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId}
|
||||
| SEDuplicateGroupMessage {groupId :: Int64, sharedMsgId :: SharedMsgId, authorGroupMemberId :: Maybe GroupMemberId, forwardedByGroupMemberId :: Maybe GroupMemberId}
|
||||
| SERemoteHostNotFound {remoteHostId :: RemoteHostId}
|
||||
| SERemoteHostUnknown -- ^ attempting to store KnownHost without a known fingerprint
|
||||
| SERemoteHostUnknown -- attempting to store KnownHost without a known fingerprint
|
||||
| SERemoteHostDuplicateCA
|
||||
| SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
|
||||
| SERemoteCtrlDuplicateCA
|
||||
|
|
|
@ -194,19 +194,19 @@ receiveFromTTY cc@ChatController {inputQ, currentUser, currentRemoteHost, chatSt
|
|||
case lm_ of
|
||||
Just LiveMessage {chatName}
|
||||
| live -> do
|
||||
writeTVar termState ts' {previousInput}
|
||||
writeTBQueue inputQ $ "/live " <> chatNameStr chatName
|
||||
writeTVar termState ts' {previousInput}
|
||||
writeTBQueue inputQ $ "/live " <> chatNameStr chatName
|
||||
| otherwise ->
|
||||
writeTVar termState ts' {inputPrompt = "> ", previousInput}
|
||||
writeTVar termState ts' {inputPrompt = "> ", previousInput}
|
||||
where
|
||||
previousInput = chatNameStr chatName <> " " <> s
|
||||
_
|
||||
| live -> when (isSend s) $ do
|
||||
writeTVar termState ts' {previousInput = s}
|
||||
writeTBQueue inputQ $ "/live " <> s
|
||||
writeTVar termState ts' {previousInput = s}
|
||||
writeTBQueue inputQ $ "/live " <> s
|
||||
| otherwise -> do
|
||||
writeTVar termState ts' {inputPrompt = "> ", previousInput = s}
|
||||
writeTBQueue inputQ s
|
||||
writeTVar termState ts' {inputPrompt = "> ", previousInput = s}
|
||||
writeTBQueue inputQ s
|
||||
pure $ (s,) <$> lm_
|
||||
where
|
||||
isSend s = length s > 1 && (head s == '@' || head s == '#')
|
||||
|
@ -343,9 +343,9 @@ updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputStr
|
|||
charsWithContact cs
|
||||
| live = cs
|
||||
| null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" && cs /= "\\" && cs /= "!" && cs /= "+" && cs /= "-" =
|
||||
chatPrefix <> cs
|
||||
chatPrefix <> cs
|
||||
| (s == ">" || s == "\\" || s == "!") && cs == " " =
|
||||
cs <> chatPrefix
|
||||
cs <> chatPrefix
|
||||
| otherwise = cs
|
||||
insertChars = ts' . if p >= length s then append else insert
|
||||
append cs = let s' = s <> cs in (s', length s')
|
||||
|
@ -381,13 +381,13 @@ updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputStr
|
|||
prevWordPos
|
||||
| p == 0 || null s = p
|
||||
| otherwise =
|
||||
let before = take p s
|
||||
beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before
|
||||
in max 0 $ p - length before + length beforeWord
|
||||
let before = take p s
|
||||
beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before
|
||||
in max 0 $ p - length before + length beforeWord
|
||||
nextWordPos
|
||||
| p >= length s || null s = p
|
||||
| otherwise =
|
||||
let after = drop p s
|
||||
afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after
|
||||
in min (length s) $ p + length after - length afterWord
|
||||
let after = drop p s
|
||||
afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after
|
||||
in min (length s) $ p + length after - length afterWord
|
||||
ts' (s', p') = ts {inputString = s', inputPosition = p', autoComplete = acp {acTabPressed = False}}
|
||||
|
|
|
@ -24,7 +24,7 @@ import Simplex.Chat (execChatCommand, processChatCommand)
|
|||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Markdown
|
||||
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.Protocol (MsgContent (..), msgContentText)
|
||||
import Simplex.Chat.Remote.Types (RHKey (..), RemoteHostId, RemoteHostInfo (..), RemoteHostSession (..))
|
||||
|
@ -167,9 +167,10 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
|
|||
void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc
|
||||
_ -> pure ()
|
||||
logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s
|
||||
getRemoteUser rhId = runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case
|
||||
CRActiveUser {user} -> updateRemoteUser ct user rhId
|
||||
cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr
|
||||
getRemoteUser rhId =
|
||||
runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case
|
||||
CRActiveUser {user} -> updateRemoteUser ct user rhId
|
||||
cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr
|
||||
removeRemoteUser rhId = atomically $ TM.delete rhId (currentRemoteUsers ct)
|
||||
|
||||
responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO ()
|
||||
|
@ -326,9 +327,9 @@ updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessag
|
|||
clearLines from till
|
||||
| from >= till = return ()
|
||||
| otherwise = do
|
||||
setCursorPosition $ Position {row = from, col = 0}
|
||||
eraseInLine EraseForward
|
||||
clearLines (from + 1) till
|
||||
setCursorPosition $ Position {row = from, col = 0}
|
||||
eraseInLine EraseForward
|
||||
clearLines (from + 1) till
|
||||
inputHeight :: TerminalState -> Int
|
||||
inputHeight ts = length (autoCompletePrefix ts <> inputPrompt ts <> inputString ts) `div` width + 1
|
||||
autoCompletePrefix :: TerminalState -> String
|
||||
|
|
|
@ -17,7 +17,6 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilyDependencies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
|
||||
{-# HLINT ignore "Use newtype instead of data" #-}
|
||||
|
@ -40,7 +39,7 @@ import qualified Data.Text as T
|
|||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Typeable (Typeable)
|
||||
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.Ok
|
||||
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.Crypto.File (CryptoFileArgs (..))
|
||||
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.Util ((<$?>))
|
||||
import Simplex.Messaging.Version
|
||||
|
@ -498,7 +497,7 @@ data LocalProfile = LocalProfile
|
|||
deriving (Eq, Show)
|
||||
|
||||
localProfileId :: LocalProfile -> ProfileId
|
||||
localProfileId LocalProfile{profileId} = profileId
|
||||
localProfileId LocalProfile {profileId} = profileId
|
||||
|
||||
toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile
|
||||
toLocalProfile profileId Profile {displayName, fullName, image, contactLink, preferences} localAlias =
|
||||
|
|
|
@ -14,7 +14,6 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilyDependencies #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
module Simplex.Chat.Types.Util where
|
||||
|
||||
import Data.Aeson (ToJSON, FromJSON)
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.ByteString (ByteString)
|
||||
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.TH as JQ
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Char (isSpace, toUpper)
|
||||
import Data.Function (on)
|
||||
|
@ -44,8 +44,8 @@ import Simplex.Chat.Markdown
|
|||
import Simplex.Chat.Messages hiding (NewChatItem (..))
|
||||
import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Remote.AppVersion (AppVersion (..), pattern AppVersionRange)
|
||||
import Simplex.Chat.Remote.Types
|
||||
import Simplex.Chat.Remote.AppVersion (pattern AppVersionRange, AppVersion (..))
|
||||
import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..))
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Types
|
||||
|
@ -308,10 +308,10 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
|||
<> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_
|
||||
CRRemoteCtrlList cs -> viewRemoteCtrls cs
|
||||
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_
|
||||
]
|
||||
<> [ "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
|
||||
deviceName = if T.null ctrlDeviceName then "" else plain ctrlDeviceName <> ", "
|
||||
CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion} ->
|
||||
|
@ -511,42 +511,43 @@ viewChats ts tz = concatMap chatPreview . reverse
|
|||
|
||||
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 =
|
||||
withGroupMsgForwarded . withItemDeleted <$> (case chat of
|
||||
DirectChat c -> case chatDir of
|
||||
CIDirectSnd -> case content of
|
||||
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
|
||||
CISndGroupEvent {} -> showSndItemProhibited to
|
||||
_ -> showSndItem to
|
||||
where
|
||||
to = ttyToContact' c
|
||||
CIDirectRcv -> case content of
|
||||
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
|
||||
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
|
||||
CIRcvGroupEvent {} -> showRcvItemProhibited from
|
||||
_ -> showRcvItem from
|
||||
where
|
||||
from = ttyFromContact c
|
||||
where
|
||||
quote = maybe [] (directQuote chatDir) quotedItem
|
||||
GroupChat g -> case chatDir of
|
||||
CIGroupSnd -> case content of
|
||||
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
|
||||
CISndGroupInvitation {} -> showSndItemProhibited to
|
||||
_ -> showSndItem to
|
||||
where
|
||||
to = ttyToGroup g
|
||||
CIGroupRcv m -> case content of
|
||||
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
|
||||
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
|
||||
CIRcvGroupInvitation {} -> showRcvItemProhibited from
|
||||
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False
|
||||
_ -> showRcvItem from
|
||||
where
|
||||
from = ttyFromGroup g m
|
||||
where
|
||||
quote = maybe [] (groupQuote g) quotedItem
|
||||
_ -> [])
|
||||
withGroupMsgForwarded . withItemDeleted <$> viewCI
|
||||
where
|
||||
viewCI = case chat of
|
||||
DirectChat c -> case chatDir of
|
||||
CIDirectSnd -> case content of
|
||||
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
|
||||
CISndGroupEvent {} -> showSndItemProhibited to
|
||||
_ -> showSndItem to
|
||||
where
|
||||
to = ttyToContact' c
|
||||
CIDirectRcv -> case content of
|
||||
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
|
||||
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
|
||||
CIRcvGroupEvent {} -> showRcvItemProhibited from
|
||||
_ -> showRcvItem from
|
||||
where
|
||||
from = ttyFromContact c
|
||||
where
|
||||
quote = maybe [] (directQuote chatDir) quotedItem
|
||||
GroupChat g -> case chatDir of
|
||||
CIGroupSnd -> case content of
|
||||
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
|
||||
CISndGroupInvitation {} -> showSndItemProhibited to
|
||||
_ -> showSndItem to
|
||||
where
|
||||
to = ttyToGroup g
|
||||
CIGroupRcv m -> case content of
|
||||
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
|
||||
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
|
||||
CIRcvGroupInvitation {} -> showRcvItemProhibited from
|
||||
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False
|
||||
_ -> showRcvItem from
|
||||
where
|
||||
from = ttyFromGroup g m
|
||||
where
|
||||
quote = maybe [] (groupQuote g) quotedItem
|
||||
_ -> []
|
||||
withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of
|
||||
Nothing -> item
|
||||
Just t -> item <> styled (colored Red) (" [" <> t <> "]")
|
||||
|
@ -667,15 +668,15 @@ viewItemDelete chat ci@ChatItem {chatDir, meta, content = deletedContent} toItem
|
|||
| timed = [plain ("timed message deleted: " <> T.unpack (ciContentToText deletedContent)) | testView]
|
||||
| byUser = [plain $ "message " <> T.unpack (fromMaybe "deleted" deletedText_)] -- deletedText_ Nothing should be impossible here
|
||||
| otherwise = case chat of
|
||||
DirectChat c -> case (chatDir, deletedContent) of
|
||||
(CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c deletedText_) [] mc ts tz meta
|
||||
DirectChat c -> case (chatDir, deletedContent) of
|
||||
(CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c deletedText_) [] mc ts tz meta
|
||||
_ -> prohibited
|
||||
GroupChat g -> case ciMsgContent deletedContent of
|
||||
Just mc ->
|
||||
let m = chatItemMember g ci
|
||||
in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta
|
||||
_ -> prohibited
|
||||
_ -> prohibited
|
||||
GroupChat g -> case ciMsgContent deletedContent of
|
||||
Just mc ->
|
||||
let m = chatItemMember g ci
|
||||
in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta
|
||||
_ -> prohibited
|
||||
_ -> prohibited
|
||||
where
|
||||
deletedText_ :: Maybe Text
|
||||
deletedText_ = case toItem of
|
||||
|
@ -788,7 +789,7 @@ viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of
|
|||
viewContactsList :: [Contact] -> [StyledString]
|
||||
viewContactsList =
|
||||
let getLDN :: Contact -> ContactName
|
||||
getLDN Contact{localDisplayName} = localDisplayName
|
||||
getLDN Contact {localDisplayName} = localDisplayName
|
||||
ldn = T.toLower . getLDN
|
||||
in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn
|
||||
where
|
||||
|
@ -823,8 +824,8 @@ simplexChatContact (CRContactUri crData) = CRContactUri crData {crScheme = simpl
|
|||
autoAcceptStatus_ :: Maybe AutoAccept -> [StyledString]
|
||||
autoAcceptStatus_ = \case
|
||||
Just AutoAccept {acceptIncognito, autoReply} ->
|
||||
("auto_accept on" <> if acceptIncognito then ", incognito" else "") :
|
||||
maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply
|
||||
("auto_accept on" <> if acceptIncognito then ", incognito" else "")
|
||||
: maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply
|
||||
_ -> ["auto_accept off"]
|
||||
|
||||
groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> GroupMemberRole -> [StyledString]
|
||||
|
@ -907,10 +908,10 @@ viewJoinedGroupMember g m =
|
|||
|
||||
viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString]
|
||||
viewReceivedGroupInvitation g c role =
|
||||
ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role) :
|
||||
case incognitoMembershipProfile g of
|
||||
Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)]
|
||||
Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"]
|
||||
ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role)
|
||||
: case incognitoMembershipProfile g of
|
||||
Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)]
|
||||
Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"]
|
||||
|
||||
groupPreserved :: GroupInfo -> [StyledString]
|
||||
groupPreserved g = ["use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the group"]
|
||||
|
@ -996,13 +997,13 @@ viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs
|
|||
GSMemRemoved -> delete "you are removed"
|
||||
GSMemLeft -> delete "you left"
|
||||
GSMemGroupDeleted -> delete "group deleted"
|
||||
_ -> " (" <> memberCount <>
|
||||
case enableNtfs of
|
||||
MFAll -> ")"
|
||||
MFNone -> ", muted, " <> unmute
|
||||
MFMentions -> ", mentions only, " <> unmute
|
||||
_ -> " (" <> memberCount <> viewNtf <> ")"
|
||||
where
|
||||
unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g) <> ")"
|
||||
viewNtf = case enableNtfs of
|
||||
MFAll -> ""
|
||||
MFNone -> ", muted, " <> unmute
|
||||
MFMentions -> ", mentions only, " <> unmute
|
||||
unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g)
|
||||
delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")"
|
||||
memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s"
|
||||
|
||||
|
@ -1028,9 +1029,9 @@ viewContactsMerged c1 c2 ct' =
|
|||
|
||||
viewContactAndMemberAssociated :: Contact -> GroupInfo -> GroupMember -> Contact -> [StyledString]
|
||||
viewContactAndMemberAssociated ct g m ct' =
|
||||
[ "contact and member are merged: " <> ttyContact' ct <> ", " <> ttyGroup' g <> " " <> ttyMember m,
|
||||
"use " <> ttyToContact' ct' <> highlight' "<message>" <> " to send messages"
|
||||
]
|
||||
[ "contact and member are merged: " <> ttyContact' ct <> ", " <> ttyGroup' g <> " " <> ttyMember m,
|
||||
"use " <> ttyToContact' ct' <> highlight' "<message>" <> " to send messages"
|
||||
]
|
||||
|
||||
viewUserProfile :: Profile -> [StyledString]
|
||||
viewUserProfile Profile {displayName, fullName} =
|
||||
|
@ -1396,14 +1397,14 @@ viewContactUpdated
|
|||
Contact {localDisplayName = n', profile = LocalProfile {fullName = fullName', contactLink = contactLink'}}
|
||||
| n == n' && fullName == fullName' && contactLink == contactLink' = []
|
||||
| n == n' && fullName == fullName' =
|
||||
if isNothing contactLink'
|
||||
then [ttyContact n <> " removed contact address"]
|
||||
else [ttyContact n <> " set new contact address, use " <> highlight ("/info " <> n) <> " to view"]
|
||||
if isNothing contactLink'
|
||||
then [ttyContact n <> " removed contact address"]
|
||||
else [ttyContact n <> " set new contact address, use " <> highlight ("/info " <> n) <> " to view"]
|
||||
| n == n' = ["contact " <> ttyContact n <> fullNameUpdate]
|
||||
| otherwise =
|
||||
[ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName',
|
||||
"use " <> ttyToContact n' <> highlight' "<message>" <> " to send messages"
|
||||
]
|
||||
[ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName',
|
||||
"use " <> ttyToContact n' <> highlight' "<message>" <> " to send messages"
|
||||
]
|
||||
where
|
||||
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
|
||||
|
||||
|
@ -1428,11 +1429,11 @@ receivedWithTime_ ts tz from quote CIMeta {itemId, itemTs, itemEdited, itemDelet
|
|||
live
|
||||
| itemEdited || isJust itemDeleted = ""
|
||||
| otherwise = case itemLive of
|
||||
Just True
|
||||
| updated -> ttyFrom "[LIVE] "
|
||||
| otherwise -> ttyFrom "[LIVE started]" <> " use " <> highlight' ("/show [on/off/" <> show itemId <> "] ")
|
||||
Just False -> ttyFrom "[LIVE ended] "
|
||||
_ -> ""
|
||||
Just True
|
||||
| updated -> ttyFrom "[LIVE] "
|
||||
| otherwise -> ttyFrom "[LIVE started]" <> " use " <> highlight' ("/show [on/off/" <> show itemId <> "] ")
|
||||
Just False -> ttyFrom "[LIVE ended] "
|
||||
_ -> ""
|
||||
|
||||
ttyMsgTime :: CurrentTime -> TimeZone -> UTCTime -> StyledString
|
||||
ttyMsgTime now tz time =
|
||||
|
@ -1458,9 +1459,9 @@ viewSentMessage to quote mc ts tz meta@CIMeta {itemEdited, itemDeleted, itemLive
|
|||
live
|
||||
| itemEdited || isJust itemDeleted = ""
|
||||
| otherwise = case itemLive of
|
||||
Just True -> ttyTo "[LIVE started] "
|
||||
Just False -> ttyTo "[LIVE] "
|
||||
_ -> ""
|
||||
Just True -> ttyTo "[LIVE started] "
|
||||
Just False -> ttyTo "[LIVE] "
|
||||
_ -> ""
|
||||
|
||||
viewSentBroadcast :: MsgContent -> Int -> Int -> CurrentTime -> TimeZone -> UTCTime -> [StyledString]
|
||||
viewSentBroadcast mc s f ts tz time = prependFirst (highlight' "/feed" <> " (" <> sShow s <> failures <> ") " <> ttyMsgTime ts tz time <> " ") (ttyMsgContent mc)
|
||||
|
@ -1551,11 +1552,12 @@ receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIF
|
|||
cfArgsStr (Just cfArgs) = [plain (cryptoFileArgsStr testView cfArgs) | status == "completed"]
|
||||
cfArgsStr _ = []
|
||||
getRemoteFileStr = case hu of
|
||||
(Just rhId, Just User {userId}) | status == "completed" ->
|
||||
[ "File received to connected remote host " <> sShow rhId,
|
||||
"To download to this device use:",
|
||||
highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f}))
|
||||
]
|
||||
(Just rhId, Just User {userId})
|
||||
| status == "completed" ->
|
||||
[ "File received to connected remote host " <> sShow rhId,
|
||||
"To download to this device use:",
|
||||
highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f}))
|
||||
]
|
||||
_ -> []
|
||||
receivingFile_' _ _ status _ = [plain status <> " receiving file"] -- shouldn't happen
|
||||
|
||||
|
@ -1591,7 +1593,7 @@ viewFileTransferStatus (FTSnd FileTransferMeta {cancelled} fts@(ft : _), chunksN
|
|||
[recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus]
|
||||
recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses
|
||||
fs :: SndFileTransfer -> FileStatus
|
||||
fs SndFileTransfer{fileStatus} = fileStatus
|
||||
fs SndFileTransfer {fileStatus} = fileStatus
|
||||
recipientsTransferStatus [] = []
|
||||
recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts]
|
||||
where
|
||||
|
@ -1763,9 +1765,10 @@ viewChatError logLevel testView = \case
|
|||
CEEmptyUserPassword _ -> ["user password is required"]
|
||||
CEUserAlreadyHidden _ -> ["user is already hidden"]
|
||||
CEUserNotHidden _ -> ["user is not hidden"]
|
||||
CEInvalidDisplayName {displayName, validName} -> map plain $
|
||||
["invalid display name: " <> viewName displayName]
|
||||
<> ["you could use this one: " <> viewName validName | not (T.null validName)]
|
||||
CEInvalidDisplayName {displayName, validName} ->
|
||||
map plain $
|
||||
["invalid display name: " <> viewName displayName]
|
||||
<> ["you could use this one: " <> viewName validName | not (T.null validName)]
|
||||
CEChatNotStarted -> ["error: chat not started"]
|
||||
CEChatNotStopped -> ["error: chat not stopped"]
|
||||
CEChatStoreChanged -> ["error: chat store changed, please restart chat"]
|
||||
|
|
|
@ -5,7 +5,6 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module ChatClient where
|
||||
|
@ -276,7 +275,7 @@ getTermLine cc =
|
|||
Just s -> do
|
||||
-- remove condition to always echo virtual terminal
|
||||
when (printOutput cc) $ do
|
||||
-- when True $ do
|
||||
-- when True $ do
|
||||
name <- userName cc
|
||||
putStrLn $ name <> ": " <> s
|
||||
pure s
|
||||
|
|
|
@ -259,7 +259,6 @@ testPlanInvitationLinkOk =
|
|||
|
||||
bob ##> ("/_connect plan 1 " <> inv)
|
||||
bob <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
|
||||
|
||||
alice <##> bob
|
||||
|
||||
testPlanInvitationLinkOwn :: HasCallStack => FilePath -> IO ()
|
||||
|
@ -283,7 +282,6 @@ testPlanInvitationLinkOwn tmp =
|
|||
|
||||
alice ##> ("/_connect plan 1 " <> inv)
|
||||
alice <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
|
||||
|
||||
alice @@@ [("@alice_1", lastChatFeature), ("@alice_2", lastChatFeature)]
|
||||
alice `send` "@alice_2 hi"
|
||||
alice
|
||||
|
@ -1213,31 +1211,34 @@ testMuteGroup =
|
|||
cath `send` "> #team (hello) hello too!"
|
||||
cath <# "#team > bob hello"
|
||||
cath <## " hello too!"
|
||||
concurrently_
|
||||
(bob </)
|
||||
( do alice <# "#team cath> > bob hello"
|
||||
alice <## " hello too!"
|
||||
)
|
||||
concurrentlyN_
|
||||
[ (bob </),
|
||||
do
|
||||
alice <# "#team cath> > bob hello"
|
||||
alice <## " hello too!"
|
||||
]
|
||||
bob ##> "/unmute mentions #team"
|
||||
bob <## "ok"
|
||||
alice `send` "> #team @bob (hello) hey bob!"
|
||||
alice <# "#team > bob hello"
|
||||
alice <## " hey bob!"
|
||||
concurrently_
|
||||
( do bob <# "#team alice> > bob hello"
|
||||
bob <## " hey bob!"
|
||||
)
|
||||
( do cath <# "#team alice> > bob hello"
|
||||
cath <## " hey bob!"
|
||||
)
|
||||
concurrentlyN_
|
||||
[ do
|
||||
bob <# "#team alice> > bob hello"
|
||||
bob <## " hey bob!",
|
||||
do
|
||||
cath <# "#team alice> > bob hello"
|
||||
cath <## " hey bob!"
|
||||
]
|
||||
alice `send` "> #team @cath (hello) hey cath!"
|
||||
alice <# "#team > cath hello too!"
|
||||
alice <## " hey cath!"
|
||||
concurrently_
|
||||
(bob </)
|
||||
( do cath <# "#team alice> > cath hello too!"
|
||||
cath <## " hey cath!"
|
||||
)
|
||||
concurrentlyN_
|
||||
[ (bob </),
|
||||
do
|
||||
cath <# "#team alice> > cath hello too!"
|
||||
cath <## " hey cath!"
|
||||
]
|
||||
bob ##> "/gs"
|
||||
bob <## "#team (3 members, mentions only, you can /unmute #team)"
|
||||
bob ##> "/unmute #team"
|
||||
|
|
|
@ -1,7 +1,6 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PostfixOperators #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module ChatTests.Files where
|
||||
|
|
|
@ -7,7 +7,7 @@ import ChatClient
|
|||
import ChatTests.Utils
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (concurrently_)
|
||||
import Control.Monad (when, void)
|
||||
import Control.Monad (void, when)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.List (isInfixOf)
|
||||
import qualified Data.Text as T
|
||||
|
@ -122,7 +122,8 @@ chatGroupTests = do
|
|||
-- because host uses current code and sends version in MemberInfo
|
||||
testNoDirect vrMem2 vrMem3 noConns =
|
||||
it
|
||||
( "host " <> vRangeStr supportedChatVRange
|
||||
( "host "
|
||||
<> vRangeStr supportedChatVRange
|
||||
<> (", 2nd mem " <> vRangeStr vrMem2)
|
||||
<> (", 3rd mem " <> vRangeStr vrMem3)
|
||||
<> (if noConns then " : 2 <!!> 3" else " : 2 <##> 3")
|
||||
|
@ -3859,11 +3860,9 @@ testMemberContactProfileUpdate =
|
|||
bob #> "#team hello too"
|
||||
alice <# "#team rob> hello too"
|
||||
cath <# "#team bob> hello too" -- not updated profile
|
||||
|
||||
cath #> "#team hello there"
|
||||
alice <# "#team kate> hello there"
|
||||
bob <# "#team cath> hello there" -- not updated profile
|
||||
|
||||
bob `send` "@cath hi"
|
||||
bob
|
||||
<### [ "member #team cath does not have direct connection, creating",
|
||||
|
@ -3903,7 +3902,6 @@ testMemberContactProfileUpdate =
|
|||
bob #> "#team hello too"
|
||||
alice <# "#team rob> hello too"
|
||||
cath <# "#team rob> hello too" -- updated profile
|
||||
|
||||
cath #> "#team hello there"
|
||||
alice <# "#team kate> hello there"
|
||||
bob <# "#team kate> hello there" -- updated profile
|
||||
|
@ -3911,7 +3909,7 @@ testMemberContactProfileUpdate =
|
|||
testGroupMsgForward :: HasCallStack => FilePath -> IO ()
|
||||
testGroupMsgForward =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
\alice bob cath -> do
|
||||
setupGroupForwarding3 "team" alice bob cath
|
||||
|
||||
bob #> "#team hi there"
|
||||
|
@ -3941,7 +3939,6 @@ setupGroupForwarding3 gName alice bob cath = do
|
|||
createGroup3 gName alice bob cath
|
||||
|
||||
threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected
|
||||
|
||||
void $ withCCTransaction bob $ \db ->
|
||||
DB.execute_ db "UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3"
|
||||
void $ withCCTransaction cath $ \db ->
|
||||
|
@ -3956,7 +3953,6 @@ testGroupMsgForwardDeduplicate =
|
|||
createGroup3 "team" alice bob cath
|
||||
|
||||
threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected
|
||||
|
||||
void $ withCCTransaction alice $ \db ->
|
||||
DB.execute_ db "UPDATE group_member_intros SET intro_status='fwd'"
|
||||
|
||||
|
@ -3990,7 +3986,7 @@ testGroupMsgForwardDeduplicate =
|
|||
testGroupMsgForwardEdit :: HasCallStack => FilePath -> IO ()
|
||||
testGroupMsgForwardEdit =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
\alice bob cath -> do
|
||||
setupGroupForwarding3 "team" alice bob cath
|
||||
|
||||
bob #> "#team hi there"
|
||||
|
@ -4001,7 +3997,6 @@ testGroupMsgForwardEdit =
|
|||
bob <# "#team [edited] hello there"
|
||||
alice <# "#team bob> [edited] hello there"
|
||||
cath <# "#team bob> [edited] hello there" -- TODO show as forwarded
|
||||
|
||||
alice ##> "/tail #team 1"
|
||||
alice <# "#team bob> hello there"
|
||||
|
||||
|
@ -4014,7 +4009,7 @@ testGroupMsgForwardEdit =
|
|||
testGroupMsgForwardReaction :: HasCallStack => FilePath -> IO ()
|
||||
testGroupMsgForwardReaction =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
\alice bob cath -> do
|
||||
setupGroupForwarding3 "team" alice bob cath
|
||||
|
||||
bob #> "#team hi there"
|
||||
|
@ -4031,7 +4026,7 @@ testGroupMsgForwardReaction =
|
|||
testGroupMsgForwardDeletion :: HasCallStack => FilePath -> IO ()
|
||||
testGroupMsgForwardDeletion =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
\alice bob cath -> do
|
||||
setupGroupForwarding3 "team" alice bob cath
|
||||
|
||||
bob #> "#team hi there"
|
||||
|
@ -4073,7 +4068,7 @@ testGroupMsgForwardFile =
|
|||
testGroupMsgForwardChangeRole :: HasCallStack => FilePath -> IO ()
|
||||
testGroupMsgForwardChangeRole =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
\alice bob cath -> do
|
||||
setupGroupForwarding3 "team" alice bob cath
|
||||
|
||||
cath ##> "/mr #team bob member"
|
||||
|
@ -4084,7 +4079,7 @@ testGroupMsgForwardChangeRole =
|
|||
testGroupMsgForwardNewMember :: HasCallStack => FilePath -> IO ()
|
||||
testGroupMsgForwardNewMember =
|
||||
testChat4 aliceProfile bobProfile cathProfile danProfile $
|
||||
\alice bob cath dan -> do
|
||||
\alice bob cath dan -> do
|
||||
setupGroupForwarding3 "team" alice bob cath
|
||||
|
||||
connectUsers cath dan
|
||||
|
|
|
@ -7,16 +7,16 @@ import ChatClient
|
|||
import ChatTests.Utils
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (concurrently_)
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Store.Shared (createContact)
|
||||
import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..), Profile (..))
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||
import System.Directory (copyFile, createDirectoryIfMissing)
|
||||
import Test.Hspec
|
||||
import Simplex.Chat.Store.Shared (createContact)
|
||||
import Control.Monad
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding(..))
|
||||
|
||||
chatProfileTests :: SpecWith FilePath
|
||||
chatProfileTests = do
|
||||
|
@ -633,7 +633,7 @@ testPlanAddressOwn tmp =
|
|||
alice <## "alice_1 (Alice) wants to connect to you!"
|
||||
alice <## "to accept: /ac alice_1"
|
||||
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 <## "alice_1 (Alice): accepting contact request..."
|
||||
alice
|
||||
|
|
|
@ -310,7 +310,7 @@ getInAnyOrder f cc ls = do
|
|||
Predicate p -> p l
|
||||
filterFirst :: (a -> Bool) -> [a] -> [a]
|
||||
filterFirst _ [] = []
|
||||
filterFirst p (x:xs)
|
||||
filterFirst p (x : xs)
|
||||
| p x = xs
|
||||
| otherwise = x : filterFirst p xs
|
||||
|
||||
|
@ -593,7 +593,7 @@ vRangeStr (VersionRange minVer maxVer) = "(" <> show minVer <> ", " <> show maxV
|
|||
linkAnotherSchema :: String -> String
|
||||
linkAnotherSchema link
|
||||
| "https://simplex.chat/" `isPrefixOf` link =
|
||||
T.unpack $ T.replace "https://simplex.chat/" "simplex:/" $ T.pack link
|
||||
T.unpack $ T.replace "https://simplex.chat/" "simplex:/" $ T.pack link
|
||||
| "simplex:/" `isPrefixOf` link =
|
||||
T.unpack $ T.replace "simplex:/" "https://simplex.chat/" $ T.pack link
|
||||
T.unpack $ T.replace "simplex:/" "https://simplex.chat/" $ T.pack link
|
||||
| otherwise = error "link starts with neither https://simplex.chat/ nor simplex:/"
|
||||
|
|
|
@ -13,8 +13,8 @@ import RemoteTests
|
|||
import SchemaDump
|
||||
import Test.Hspec
|
||||
import UnliftIO.Temporary (withTempDirectory)
|
||||
import ViewTests
|
||||
import ValidNames
|
||||
import ViewTests
|
||||
import WebRTCTests
|
||||
|
||||
main :: IO ()
|
||||
|
|
Loading…
Add table
Reference in a new issue