core: use fourmolu styles (#3470)

This commit is contained in:
Evgeny Poberezkin 2023-11-26 18:16:37 +00:00 committed by GitHub
parent 75c2de8a12
commit d29f1bb0cf
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
43 changed files with 902 additions and 865 deletions

30
fourmolu.yaml Normal file
View 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

View file

@ -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

View file

@ -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)

View file

@ -225,4 +225,3 @@ instance FromField CallState where
fromField = fromTextField_ decodeJSON
$(J.deriveJSON defaultJSON ''RcvCallInvitation)

View file

@ -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)

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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}}}

View file

@ -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"

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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 =

View file

@ -13,7 +13,6 @@
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Protocol where

View file

@ -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 ->

View file

@ -11,7 +11,7 @@ module Simplex.Chat.Remote.AppVersion
compatibleAppVersion,
isAppCompatible,
)
where
where
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J

View file

@ -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

View file

@ -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

View file

@ -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 (..))

View file

@ -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

View file

@ -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])

View file

@ -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)

View file

@ -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 ()

View file

@ -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'

View file

@ -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 =

View file

@ -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

View file

@ -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

View file

@ -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}}

View file

@ -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

View file

@ -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 =

View file

@ -14,7 +14,6 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

View file

@ -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

View file

@ -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"]

View file

@ -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

View file

@ -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"

View file

@ -1,7 +1,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module ChatTests.Files where

View file

@ -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

View file

@ -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

View file

@ -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:/"

View file

@ -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 ()