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

@ -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,7 +85,9 @@ newtype FormatColor = FormatColor Color
deriving (Eq, Show)
instance FromJSON FormatColor where
parseJSON = J.withText "FormatColor" $ fmap FormatColor . \case
parseJSON =
J.withText "FormatColor" $
fmap FormatColor . \case
"red" -> pure Red
"green" -> pure Green
"blue" -> pure Blue

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, (<$?>))

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,8 +46,8 @@ data SndConnEvent
| SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef}
deriving (Show)
data RcvDirectEvent =
-- RDEProfileChanged {...}
data RcvDirectEvent
= -- RDEProfileChanged {...}
RDEContactDeleted
deriving (Show)

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)

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,
module Simplex.Chat.Mobile.WebRTC
( cChatEncryptMedia,
cChatDecryptMedia,
chatEncryptMedia,
chatDecryptMedia,
reservedSize,
) where
) 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

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

View file

@ -97,7 +97,8 @@ discoveryTimeout = 60000000
getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient
getRemoteHostClient rhId = do
sessions <- asks remoteHostSessions
liftIOEither . atomically $ TM.lookup rhKey sessions >>= \case
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
@ -107,7 +108,8 @@ getRemoteHostClient rhId = do
withRemoteHostSession :: ChatMonad m => RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> m a
withRemoteHostSession rhKey sseq f = do
sessions <- asks remoteHostSessions
r <- atomically $
r <-
atomically $
TM.lookup rhKey sessions >>= \case
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
Just (stateSeq, state)
@ -167,12 +169,14 @@ 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
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
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 ()
@ -250,7 +254,8 @@ cancelRemoteHostSession :: ChatMonad m => Maybe (SessionSeq, RemoteHostStopReaso
cancelRemoteHostSession handlerInfo_ rhKey = do
sessions <- asks remoteHostSessions
crh <- asks currentRemoteHost
deregistered <- atomically $
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
@ -401,7 +406,8 @@ 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
rc <-
withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case
Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl"
Just rc -> pure rc
atomically $ putTMVar foundCtrl (rc, inv)
@ -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,9 +653,11 @@ 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
session_ <-
atomically $
readTVar var >>= \case
Nothing -> pure Nothing
Just (oldSeq, _) | maybe False (/= oldSeq) (fst <$> handlerInfo_) -> pure Nothing
Just (oldSeq, _) | (maybe False ((oldSeq /=) . fst) handlerInfo_) -> pure Nothing
Just (_, s) -> Just s <$ writeTVar var Nothing
forM_ session_ $ \session -> do
liftIO $ cancelRemoteCtrl handlingError session

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
@ -48,9 +48,9 @@ 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

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,

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,7 +156,8 @@ 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 $
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_
@ -167,7 +167,8 @@ 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 $
connId_ <-
maybeFirstRow fromOnly $
DB.query
db
[sql|

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
@ -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,7 +234,8 @@ 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 $
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"
@ -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

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)
@ -957,8 +956,9 @@ createNewMember_
:. (minV, maxV)
)
groupMemberId <- insertedRowId db
pure GroupMember {
groupMemberId,
pure
GroupMember
{ groupMemberId,
groupId,
memberId,
memberRole,
@ -1317,7 +1317,8 @@ 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 $
groupId_ <-
maybeFirstRow fromOnly $
DB.query
db
[sql|
@ -1330,7 +1331,8 @@ getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSch
getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
groupId_ <- maybeFirstRow fromOnly $
groupId_ <-
maybeFirstRow fromOnly $
DB.query
db
[sql|

View file

@ -10,7 +10,6 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Messages
@ -199,12 +198,13 @@ 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 sharedMsgId ->
liftIO (duplicateGroupMsgMemberIds groupId sharedMsgId) >>= \case
Just (duplAuthorId, duplFwdMemberId) ->
throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
@ -212,8 +212,8 @@ createNewRcvMessage db connOrGroupId NewMessage{chatMsgEvent, msgBody} sharedMsg
where
duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId))
duplicateGroupMsgMemberIds groupId sharedMsgId =
maybeFirstRow id
$ DB.query
maybeFirstRow id $
DB.query
db
[sql|
SELECT author_group_member_id, forwarded_by_group_member_id
@ -232,7 +232,7 @@ createNewRcvMessage db connOrGroupId NewMessage{chatMsgEvent, msgBody} sharedMsg
|]
(MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember)
msgId <- insertedRowId db
pure RcvMessage{msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember}
pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember}
createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO ()
createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do

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
@ -457,7 +456,8 @@ 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 $
ctId_ <-
maybeFirstRow fromOnly $
DB.query
db
[sql|

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

@ -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,7 +167,8 @@ 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
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)

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,7 +511,9 @@ viewChats ts tz = concatMap chatPreview . reverse
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember}, content, quotedItem, file} doShow ts tz =
withGroupMsgForwarded . withItemDeleted <$> (case chat of
withGroupMsgForwarded . withItemDeleted <$> viewCI
where
viewCI = case chat of
DirectChat c -> case chatDir of
CIDirectSnd -> case content of
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
@ -545,8 +547,7 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember},
from = ttyFromGroup g m
where
quote = maybe [] (groupQuote g) quotedItem
_ -> [])
where
_ -> []
withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of
Nothing -> item
Just t -> item <> styled (colored Red) (" [" <> t <> "]")
@ -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,8 +908,8 @@ 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
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"]
@ -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 -> ")"
_ -> " (" <> memberCount <> viewNtf <> ")"
where
viewNtf = case enableNtfs of
MFAll -> ""
MFNone -> ", muted, " <> unmute
MFMentions -> ", mentions only, " <> unmute
where
unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g) <> ")"
unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g)
delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")"
memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s"
@ -1551,7 +1552,8 @@ receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIF
cfArgsStr (Just cfArgs) = [plain (cryptoFileArgsStr testView cfArgs) | status == "completed"]
cfArgsStr _ = []
getRemoteFileStr = case hu of
(Just rhId, Just User {userId}) | status == "completed" ->
(Just rhId, Just User {userId})
| status == "completed" ->
[ "File received to connected remote host " <> sShow rhId,
"To download to this device use:",
highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f}))
@ -1591,7 +1593,7 @@ viewFileTransferStatus (FTSnd FileTransferMeta {cancelled} fts@(ft : _), chunksN
[recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus]
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,7 +1765,8 @@ viewChatError logLevel testView = \case
CEEmptyUserPassword _ -> ["user password is required"]
CEUserAlreadyHidden _ -> ["user is already hidden"]
CEUserNotHidden _ -> ["user is not hidden"]
CEInvalidDisplayName {displayName, validName} -> map plain $
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"]

View file

@ -5,7 +5,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module ChatClient where

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

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

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