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 qualified Database.SQLite3 as SQL
import Simplex.Chat.Controller import Simplex.Chat.Controller
import Simplex.Messaging.Agent.Client (agentClientStore) import Simplex.Messaging.Agent.Client (agentClientStore)
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), sqlString, closeSQLiteStore) import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), closeSQLiteStore, sqlString)
import Simplex.Messaging.Util import Simplex.Messaging.Util
import System.FilePath import System.FilePath
import UnliftIO.Directory import UnliftIO.Directory

View file

@ -6,8 +6,8 @@ module Simplex.Chat.Bot.KnownContacts where
import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Int (Int64) import Data.Int (Int64)
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Options.Applicative import Options.Applicative
import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Util (safeDecodeUtf8) import Simplex.Messaging.Util (safeDecodeUtf8)

View file

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

View file

@ -1,5 +1,5 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
@ -426,19 +426,19 @@ data ChatCommand
| SetGroupTimedMessages GroupName (Maybe Int) | SetGroupTimedMessages GroupName (Maybe Int)
| SetLocalDeviceName Text | SetLocalDeviceName Text
| ListRemoteHosts | ListRemoteHosts
| StartRemoteHost (Maybe (RemoteHostId, Bool)) -- ^ Start new or known remote host with optional multicast for known host | StartRemoteHost (Maybe (RemoteHostId, Bool)) -- Start new or known remote host with optional multicast for known host
| SwitchRemoteHost (Maybe RemoteHostId) -- ^ Switch current remote host | SwitchRemoteHost (Maybe RemoteHostId) -- Switch current remote host
| StopRemoteHost RHKey -- ^ Shut down a running session | StopRemoteHost RHKey -- Shut down a running session
| DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data | DeleteRemoteHost RemoteHostId -- Unregister remote host and remove its data
| StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath} | StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath}
| GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile} | GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile}
| ConnectRemoteCtrl RCSignedInvitation -- ^ Connect new or existing controller via OOB data | ConnectRemoteCtrl RCSignedInvitation -- Connect new or existing controller via OOB data
| FindKnownRemoteCtrl -- ^ Start listening for announcements from all existing controllers | FindKnownRemoteCtrl -- Start listening for announcements from all existing controllers
| ConfirmRemoteCtrl RemoteCtrlId -- ^ Confirm the connection with found controller | ConfirmRemoteCtrl RemoteCtrlId -- Confirm the connection with found controller
| VerifyRemoteCtrlSession Text -- ^ Verify remote controller session | VerifyRemoteCtrlSession Text -- Verify remote controller session
| ListRemoteCtrls | ListRemoteCtrls
| StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session | StopRemoteCtrl -- Stop listening for announcements or terminate an active session
| DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a remote controller session | DeleteRemoteCtrl RemoteCtrlId -- Remove all local data associated with a remote controller session
| QuitChat | QuitChat
| ShowVersion | ShowVersion
| DebugLocks | DebugLocks
@ -1072,13 +1072,13 @@ throwDBError = throwError . ChatErrorDatabase
-- TODO review errors, some of it can be covered by HTTP2 errors -- TODO review errors, some of it can be covered by HTTP2 errors
data RemoteHostError data RemoteHostError
= RHEMissing -- ^ No remote session matches this identifier = RHEMissing -- No remote session matches this identifier
| RHEInactive -- ^ A session exists, but not active | RHEInactive -- A session exists, but not active
| RHEBusy -- ^ A session is already running | RHEBusy -- A session is already running
| RHETimeout | RHETimeout
| RHEBadState -- ^ Illegal state transition | RHEBadState -- Illegal state transition
| RHEBadVersion {appVersion :: AppVersion} | RHEBadVersion {appVersion :: AppVersion}
| RHELocalCommand -- ^ Command not allowed for remote execution | RHELocalCommand -- Command not allowed for remote execution
| RHEDisconnected {reason :: Text} -- TODO should be sent when disconnected? | RHEDisconnected {reason :: Text} -- TODO should be sent when disconnected?
| RHEProtocolError RemoteProtocolError | RHEProtocolError RemoteProtocolError
deriving (Show, Exception) deriving (Show, Exception)
@ -1091,13 +1091,14 @@ data RemoteHostStopReason
-- TODO review errors, some of it can be covered by HTTP2 errors -- TODO review errors, some of it can be covered by HTTP2 errors
data RemoteCtrlError data RemoteCtrlError
= RCEInactive -- ^ No session is running = RCEInactive -- No session is running
| RCEBadState -- ^ A session is in a wrong state for the current operation | RCEBadState -- A session is in a wrong state for the current operation
| RCEBusy -- ^ A session is already running | RCEBusy -- A session is already running
| RCETimeout | RCETimeout
| RCENoKnownControllers -- ^ No previously-contacted controllers to discover | RCENoKnownControllers -- No previously-contacted controllers to discover
| RCEBadController -- ^ Attempting to confirm a found controller with another ID | RCEBadController -- Attempting to confirm a found controller with another ID
| RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected by a controller | -- | A session disconnected by a controller
RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text}
| RCEBadInvitation | RCEBadInvitation
| RCEBadVersion {appVersion :: AppVersion} | RCEBadVersion {appVersion :: AppVersion}
| RCEHTTP2Error {http2Error :: Text} -- TODO currently not used | RCEHTTP2Error {http2Error :: Text} -- TODO currently not used
@ -1223,8 +1224,8 @@ toView event = do
session <- asks remoteCtrlSession session <- asks remoteCtrlSession
atomically $ atomically $
readTVar session >>= \case readTVar session >>= \case
Just (_, RCSessionConnected {remoteOutputQ}) | allowRemoteEvent event -> Just (_, RCSessionConnected {remoteOutputQ})
writeTBQueue remoteOutputQ event | allowRemoteEvent event -> writeTBQueue remoteOutputQ event
-- TODO potentially, it should hold some events while connecting -- TODO potentially, it should hold some events while connecting
_ -> writeTBQueue localQ (Nothing, Nothing, event) _ -> writeTBQueue localQ (Nothing, Nothing, event)

View file

@ -6,8 +6,8 @@ module Simplex.Chat.Files where
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Simplex.Chat.Controller import Simplex.Chat.Controller
import Simplex.Messaging.Util (ifM) import Simplex.Messaging.Util (ifM)
import System.FilePath (splitExtensions, combine) import System.FilePath (combine, splitExtensions)
import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, getHomeDirectory, doesDirectoryExist) import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getHomeDirectory, getTemporaryDirectory)
uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
uniqueCombine fPath fName = tryCombine (0 :: Int) uniqueCombine fPath fName = tryCombine (0 :: Int)

View file

@ -19,7 +19,7 @@ import qualified Data.Attoparsec.Text as A
import Data.Char (isDigit, isPunctuation) import Data.Char (isDigit, isPunctuation)
import Data.Either (fromRight) import Data.Either (fromRight)
import Data.Functor (($>)) import Data.Functor (($>))
import Data.List (intercalate, foldl') import Data.List (foldl', intercalate)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe, isNothing) import Data.Maybe (fromMaybe, isNothing)
@ -85,7 +85,9 @@ newtype FormatColor = FormatColor Color
deriving (Eq, Show) deriving (Eq, Show)
instance FromJSON FormatColor where instance FromJSON FormatColor where
parseJSON = J.withText "FormatColor" $ fmap FormatColor . \case parseJSON =
J.withText "FormatColor" $
fmap FormatColor . \case
"red" -> pure Red "red" -> pure Red
"green" -> pure Green "green" -> pure Green
"blue" -> pure Blue "blue" -> pure Blue

View file

@ -11,7 +11,6 @@
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Messages where module Simplex.Chat.Messages where
@ -44,7 +43,7 @@ import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptSta
import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Crypto.File (CryptoFile (..))
import qualified Simplex.Messaging.Crypto.File as CF import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, parseAll, enumJSON, sumTypeJSON) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, parseAll, sumTypeJSON)
import Simplex.Messaging.Protocol (MsgBody) import Simplex.Messaging.Protocol (MsgBody)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>)) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))

View file

@ -311,7 +311,7 @@ profileToText Profile {displayName, fullName} = displayName <> optionalFullName
msgIntegrityError :: MsgErrorType -> Text msgIntegrityError :: MsgErrorType -> Text
msgIntegrityError = \case msgIntegrityError = \case
MsgSkipped fromId toId -> MsgSkipped fromId toId ->
"skipped message ID " <> tshow fromId ("skipped message ID " <> tshow fromId)
<> if fromId == toId then "" else ".." <> tshow toId <> if fromId == toId then "" else ".." <> tshow toId
MsgBadId msgId -> "unexpected message ID " <> tshow msgId MsgBadId msgId -> "unexpected message ID " <> tshow msgId
MsgBadHash -> "incorrect message hash" MsgBadHash -> "incorrect message hash"

View file

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

View file

@ -4,13 +4,12 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fobject-code #-} {-# OPTIONS_GHC -fobject-code #-}
module Simplex.Chat.Mobile where module Simplex.Chat.Mobile where
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Exception (catch, SomeException) import Control.Exception (SomeException, catch)
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Reader import Control.Monad.Reader
import qualified Data.Aeson as J import qualified Data.Aeson as J
@ -31,7 +30,7 @@ import Foreign.C.Types (CInt (..))
import Foreign.Ptr import Foreign.Ptr
import Foreign.StablePtr import Foreign.StablePtr
import Foreign.Storable (poke) import Foreign.Storable (poke)
import GHC.IO.Encoding (setLocaleEncoding, setFileSystemEncoding, setForeignEncoding) import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding)
import Simplex.Chat import Simplex.Chat
import Simplex.Chat.Controller import Simplex.Chat.Controller
import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList) import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)

View file

@ -6,8 +6,8 @@ import qualified Data.ByteString as B
import Data.ByteString.Internal (ByteString (..), memcpy) import Data.ByteString.Internal (ByteString (..), memcpy)
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Internal as LB import qualified Data.ByteString.Lazy.Internal as LB
import Foreign.C (CInt, CString)
import Foreign import Foreign
import Foreign.C (CInt, CString)
type CJSONString = CString type CJSONString = CString

View file

@ -1,12 +1,12 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
module Simplex.Chat.Mobile.WebRTC ( module Simplex.Chat.Mobile.WebRTC
cChatEncryptMedia, ( cChatEncryptMedia,
cChatDecryptMedia, cChatDecryptMedia,
chatEncryptMedia, chatEncryptMedia,
chatDecryptMedia, chatDecryptMedia,
reservedSize, reservedSize,
) where ) where
import Control.Monad import Control.Monad
import Control.Monad.Except import Control.Monad.Except
@ -21,8 +21,8 @@ import Data.Either (fromLeft)
import Data.Word (Word8) import Data.Word (Word8)
import Foreign.C (CInt, CString, newCAString) import Foreign.C (CInt, CString, newCAString)
import Foreign.Ptr (Ptr) import Foreign.Ptr (Ptr)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Chat.Mobile.Shared import Simplex.Chat.Mobile.Shared
import qualified Simplex.Messaging.Crypto as C
cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
cChatEncryptMedia = cTransformMedia chatEncryptMedia cChatEncryptMedia = cTransformMedia chatEncryptMedia

View file

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

View file

@ -97,7 +97,8 @@ discoveryTimeout = 60000000
getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient
getRemoteHostClient rhId = do getRemoteHostClient rhId = do
sessions <- asks remoteHostSessions sessions <- asks remoteHostSessions
liftIOEither . atomically $ TM.lookup rhKey sessions >>= \case liftIOEither . atomically $
TM.lookup rhKey sessions >>= \case
Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient
Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
@ -107,7 +108,8 @@ getRemoteHostClient rhId = do
withRemoteHostSession :: ChatMonad m => RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> m a withRemoteHostSession :: ChatMonad m => RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> m a
withRemoteHostSession rhKey sseq f = do withRemoteHostSession rhKey sseq f = do
sessions <- asks remoteHostSessions sessions <- asks remoteHostSessions
r <- atomically $ r <-
atomically $
TM.lookup rhKey sessions >>= \case TM.lookup rhKey sessions >>= \case
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
Just (stateSeq, state) Just (stateSeq, state)
@ -167,12 +169,14 @@ startRemoteHost rh_ = do
when (encoding == PEKotlin && localEncoding == PESwift) $ throwError $ RHEProtocolError RPEIncompatibleEncoding when (encoding == PEKotlin && localEncoding == PESwift) $ throwError $ RHEProtocolError RPEIncompatibleEncoding
pure hostInfo pure hostInfo
handleConnectError :: ChatMonad m => RHKey -> SessionSeq -> m a -> m a handleConnectError :: ChatMonad m => RHKey -> SessionSeq -> m a -> m a
handleConnectError rhKey sessSeq action = action `catchChatError` \err -> do handleConnectError rhKey sessSeq action =
action `catchChatError` \err -> do
logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err
cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey
throwError err throwError err
handleHostError :: ChatMonad m => SessionSeq -> TVar RHKey -> m () -> m () handleHostError :: ChatMonad m => SessionSeq -> TVar RHKey -> m () -> m ()
handleHostError sessSeq rhKeyVar action = action `catchChatError` \err -> do handleHostError sessSeq rhKeyVar action =
action `catchChatError` \err -> do
logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err
readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err)) readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err))
waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m () waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m ()
@ -250,7 +254,8 @@ cancelRemoteHostSession :: ChatMonad m => Maybe (SessionSeq, RemoteHostStopReaso
cancelRemoteHostSession handlerInfo_ rhKey = do cancelRemoteHostSession handlerInfo_ rhKey = do
sessions <- asks remoteHostSessions sessions <- asks remoteHostSessions
crh <- asks currentRemoteHost crh <- asks currentRemoteHost
deregistered <- atomically $ deregistered <-
atomically $
TM.lookup rhKey sessions >>= \case TM.lookup rhKey sessions >>= \case
Nothing -> pure Nothing Nothing -> pure Nothing
Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler
@ -401,7 +406,8 @@ findKnownRemoteCtrl = do
(RCCtrlPairing {ctrlFingerprint}, inv@(RCVerifiedInvitation RCInvitation {app})) <- (RCCtrlPairing {ctrlFingerprint}, inv@(RCVerifiedInvitation RCInvitation {app})) <-
timeoutThrow (ChatErrorRemoteCtrl RCETimeout) discoveryTimeout . withAgent $ \a -> rcDiscoverCtrl a pairings timeoutThrow (ChatErrorRemoteCtrl RCETimeout) discoveryTimeout . withAgent $ \a -> rcDiscoverCtrl a pairings
ctrlAppInfo_ <- (Just <$> parseCtrlAppInfo app) `catchChatError` const (pure Nothing) ctrlAppInfo_ <- (Just <$> parseCtrlAppInfo app) `catchChatError` const (pure Nothing)
rc <- withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case rc <-
withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case
Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl" Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl"
Just rc -> pure rc Just rc -> pure rc
atomically $ putTMVar foundCtrl (rc, inv) atomically $ putTMVar foundCtrl (rc, inv)
@ -422,7 +428,7 @@ confirmRemoteCtrl rcId = do
pure $ Right (sseq, action, foundCtrl) pure $ Right (sseq, action, foundCtrl)
_ -> pure . Left $ ChatErrorRemoteCtrl RCEBadState _ -> pure . Left $ ChatErrorRemoteCtrl RCEBadState
uninterruptibleCancel listener uninterruptibleCancel listener
(RemoteCtrl{remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found (RemoteCtrl {remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found
unless (rcId == foundRcId) $ throwError $ ChatErrorRemoteCtrl RCEBadController unless (rcId == foundRcId) $ throwError $ ChatErrorRemoteCtrl RCEBadController
connectRemoteCtrl verifiedInv sseq >>= \case connectRemoteCtrl verifiedInv sseq >>= \case
(Nothing, _) -> throwChatError $ CEInternalError "connecting with a stored ctrl" (Nothing, _) -> throwChatError $ CEInternalError "connecting with a stored ctrl"
@ -647,9 +653,11 @@ handleCtrlError sseq mkReason name action =
cancelActiveRemoteCtrl :: ChatMonad m => Maybe (SessionSeq, RemoteCtrlStopReason) -> m () cancelActiveRemoteCtrl :: ChatMonad m => Maybe (SessionSeq, RemoteCtrlStopReason) -> m ()
cancelActiveRemoteCtrl handlerInfo_ = handleAny (logError . tshow) $ do cancelActiveRemoteCtrl handlerInfo_ = handleAny (logError . tshow) $ do
var <- asks remoteCtrlSession var <- asks remoteCtrlSession
session_ <- atomically $ readTVar var >>= \case session_ <-
atomically $
readTVar var >>= \case
Nothing -> pure Nothing Nothing -> pure Nothing
Just (oldSeq, _) | maybe False (/= oldSeq) (fst <$> handlerInfo_) -> pure Nothing Just (oldSeq, _) | (maybe False ((oldSeq /=) . fst) handlerInfo_) -> pure Nothing
Just (_, s) -> Just s <$ writeTVar var Nothing Just (_, s) -> Just s <$ writeTVar var Nothing
forM_ session_ $ \session -> do forM_ session_ $ \session -> do
liftIO $ cancelRemoteCtrl handlingError session liftIO $ cancelRemoteCtrl handlingError session

View file

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

View file

@ -6,10 +6,8 @@ import Network.Socket
#include <HsNet.h> #include <HsNet.h>
{- | Toggle multicast group membership. -- | Toggle multicast group membership.
-- NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups.
NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups.
-}
setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ()) setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ())
setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do
#{poke struct ip_mreq, imr_multiaddr} mReqPtr group #{poke struct ip_mreq, imr_multiaddr} mReqPtr group

View file

@ -6,8 +6,8 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Chat.Remote.Protocol where module Simplex.Chat.Remote.Protocol where
@ -48,9 +48,9 @@ import Simplex.Messaging.Transport.Buffer (getBuffered)
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk) import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk)
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect)
import Simplex.Messaging.Util (liftEitherError, liftEitherWith, liftError, tshow) import Simplex.Messaging.Util (liftEitherError, liftEitherWith, liftError, tshow)
import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode)
import Simplex.RemoteControl.Client (xrcpBlockSize) import Simplex.RemoteControl.Client (xrcpBlockSize)
import qualified Simplex.RemoteControl.Client as RC import qualified Simplex.RemoteControl.Client as RC
import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode)
import System.FilePath (takeFileName, (</>)) import System.FilePath (takeFileName, (</>))
import UnliftIO import UnliftIO
@ -64,10 +64,10 @@ data RemoteCommand
data RemoteResponse data RemoteResponse
= RRChatResponse {chatResponse :: ChatResponse} = RRChatResponse {chatResponse :: ChatResponse}
| RRChatEvent {chatEvent :: Maybe ChatResponse} -- ^ 'Nothing' on poll timeout | RRChatEvent {chatEvent :: Maybe ChatResponse} -- 'Nothing' on poll timeout
| RRFileStored {filePath :: String} | RRFileStored {filePath :: String}
| RRFile {fileSize :: Word32, fileDigest :: FileDigest} -- provides attachment , fileDigest :: FileDigest | RRFile {fileSize :: Word32, fileDigest :: FileDigest} -- provides attachment , fileDigest :: FileDigest
| RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- ^ The protocol error happened on the server side | RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- The protocol error happened on the server side
deriving (Show) deriving (Show)
-- Force platform-independent encoding as the types aren't UI-visible -- Force platform-independent encoding as the types aren't UI-visible
@ -126,7 +126,7 @@ remoteStoreFile c localPath fileName = do
r -> badResponse r r -> badResponse r
remoteGetFile :: RemoteHostClient -> FilePath -> RemoteFile -> ExceptT RemoteProtocolError IO () remoteGetFile :: RemoteHostClient -> FilePath -> RemoteFile -> ExceptT RemoteProtocolError IO ()
remoteGetFile c@RemoteHostClient{encryption} destDir rf@RemoteFile {fileSource = CryptoFile {filePath}} = remoteGetFile c@RemoteHostClient {encryption} destDir rf@RemoteFile {fileSource = CryptoFile {filePath}} =
sendRemoteCommand c Nothing RCGetFile {file = rf} >>= \case sendRemoteCommand c Nothing RCGetFile {file = rf} >>= \case
(getChunk, RRFile {fileSize, fileDigest}) -> do (getChunk, RRFile {fileSize, fileDigest}) -> do
-- TODO we could optimize by checking size and hash before receiving the file -- TODO we could optimize by checking size and hash before receiving the file

View file

@ -5,15 +5,15 @@ module Simplex.Chat.Remote.Transport where
import Control.Monad import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Data.ByteString.Builder (Builder, byteString)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder, byteString)
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy as LB
import Data.Word (Word32) import Data.Word (Word32)
import Simplex.FileTransfer.Description (FileDigest (..))
import Simplex.Chat.Remote.Types import Simplex.Chat.Remote.Types
import Simplex.FileTransfer.Description (FileDigest (..))
import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sendEncFile)
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Lazy as LC import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sendEncFile)
import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding
import Simplex.Messaging.Util (liftEitherError, liftEitherWith) import Simplex.Messaging.Util (liftEitherError, liftEitherWith)
import Simplex.RemoteControl.Types (RCErrorType (..)) import Simplex.RemoteControl.Types (RCErrorType (..))

View file

@ -21,13 +21,13 @@ import Data.Text (Text)
import Simplex.Chat.Remote.AppVersion import Simplex.Chat.Remote.AppVersion
import Simplex.Chat.Types (verificationCode) import Simplex.Chat.Types (verificationCode)
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile)
import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret) import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
import Simplex.Messaging.Transport (TLS (..))
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
import Simplex.RemoteControl.Client import Simplex.RemoteControl.Client
import Simplex.RemoteControl.Types import Simplex.RemoteControl.Types
import Simplex.Messaging.Crypto.File (CryptoFile)
import Simplex.Messaging.Transport (TLS (..))
data RemoteHostClient = RemoteHostClient data RemoteHostClient = RemoteHostClient
{ hostEncoding :: PlatformEncoding, { hostEncoding :: PlatformEncoding,

View file

@ -4,7 +4,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Connections module Simplex.Chat.Store.Connections
@ -25,11 +24,11 @@ import Data.Text (Text)
import Data.Time.Clock (UTCTime (..)) import Data.Time.Clock (UTCTime (..))
import Database.SQLite.Simple (Only (..), (:.) (..)) import Database.SQLite.Simple (Only (..), (:.) (..))
import Database.SQLite.Simple.QQ (sql) import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Protocol
import Simplex.Chat.Store.Files import Simplex.Chat.Store.Files
import Simplex.Chat.Store.Groups import Simplex.Chat.Store.Groups
import Simplex.Chat.Store.Profiles import Simplex.Chat.Store.Profiles
import Simplex.Chat.Store.Shared import Simplex.Chat.Store.Shared
import Simplex.Chat.Protocol
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent.Protocol (ConnId) import Simplex.Messaging.Agent.Protocol (ConnId)
@ -157,7 +156,8 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity) getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
connId_ <- maybeFirstRow fromOnly $ connId_ <-
maybeFirstRow fromOnly $
DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2) DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_ maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
@ -167,7 +167,8 @@ getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) =
-- deleted connections are filtered out to allow re-connecting via same contact address -- deleted connections are filtered out to allow re-connecting via same contact address
getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity) getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do
connId_ <- maybeFirstRow fromOnly $ connId_ <-
maybeFirstRow fromOnly $
DB.query DB.query
db db
[sql| [sql|

View file

@ -1,13 +1,12 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Direct module Simplex.Chat.Store.Direct
@ -784,10 +783,8 @@ updateConnectionStatus :: DB.Connection -> Connection -> ConnStatus -> IO ()
updateConnectionStatus db Connection {connId} connStatus = do updateConnectionStatus db Connection {connId} connStatus = do
currentTs <- getCurrentTime currentTs <- getCurrentTime
if connStatus == ConnReady if connStatus == ConnReady
then then DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ?, conn_req_inv = NULL WHERE connection_id = ?" (connStatus, currentTs, connId)
DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ?, conn_req_inv = NULL WHERE connection_id = ?" (connStatus, currentTs, connId) else DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId)
else
DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId)
updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO () updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO ()
updateContactSettings db User {userId} contactId ChatSettings {enableNtfs, sendRcpts, favorite} = updateContactSettings db User {userId} contactId ChatSettings {enableNtfs, sendRcpts, favorite} =
@ -816,4 +813,3 @@ resetContactConnInitiated db User {userId} Connection {connId} = do
WHERE user_id = ? AND connection_id = ? WHERE user_id = ? AND connection_id = ?
|] |]
(updatedAt, userId, connId) (updatedAt, userId, connId)

View file

@ -109,7 +109,7 @@ import Simplex.Messaging.Protocol (SubscriptionMode (..))
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer] getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
getLiveSndFileTransfers db User {userId} = do getLiveSndFileTransfers db User {userId} = do
cutoffTs <- addUTCTime (- week) <$> getCurrentTime cutoffTs <- addUTCTime (-week) <$> getCurrentTime
fileIds :: [Int64] <- fileIds :: [Int64] <-
map fromOnly map fromOnly
<$> DB.query <$> DB.query
@ -132,7 +132,7 @@ getLiveSndFileTransfers db User {userId} = do
getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer] getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer]
getLiveRcvFileTransfers db user@User {userId} = do getLiveRcvFileTransfers db user@User {userId} = do
cutoffTs <- addUTCTime (- week) <$> getCurrentTime cutoffTs <- addUTCTime (-week) <$> getCurrentTime
fileIds :: [Int64] <- fileIds :: [Int64] <-
map fromOnly map fromOnly
<$> DB.query <$> DB.query
@ -234,7 +234,8 @@ createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Conn
updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> ExceptT StoreError IO () updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> ExceptT StoreError IO ()
updateSndDirectFTDelivery _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName updateSndDirectFTDelivery _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = liftIO $ updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId =
liftIO $
DB.execute DB.execute
db db
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
@ -724,7 +725,7 @@ removeFileCryptoArgs db fileId = do
getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer] getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer]
getRcvFilesToReceive db user@User {userId} = do getRcvFilesToReceive db user@User {userId} = do
cutoffTs <- addUTCTime (- (2 * nominalDay)) <$> getCurrentTime cutoffTs <- addUTCTime (-(2 * nominalDay)) <$> getCurrentTime
fileIds :: [Int64] <- fileIds :: [Int64] <-
map fromOnly map fromOnly
<$> DB.query <$> DB.query

View file

@ -2,14 +2,13 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Groups module Simplex.Chat.Store.Groups
@ -122,7 +121,7 @@ import Crypto.Random (ChaChaDRG)
import Data.Either (rights) import Data.Either (rights)
import Data.Int (Int64) import Data.Int (Int64)
import Data.List (partition, sortOn) import Data.List (partition, sortOn)
import Data.Maybe (fromMaybe, isNothing, catMaybes, isJust) import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
import Data.Ord (Down (..)) import Data.Ord (Down (..))
import Data.Text (Text) import Data.Text (Text)
import Data.Time.Clock (UTCTime (..), getCurrentTime) import Data.Time.Clock (UTCTime (..), getCurrentTime)
@ -957,8 +956,9 @@ createNewMember_
:. (minV, maxV) :. (minV, maxV)
) )
groupMemberId <- insertedRowId db groupMemberId <- insertedRowId db
pure GroupMember { pure
groupMemberId, GroupMember
{ groupMemberId,
groupId, groupId,
memberId, memberId,
memberRole, memberRole,
@ -1317,7 +1317,8 @@ getGroupInfo db User {userId, userContactId} groupId =
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo) getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
groupId_ <- maybeFirstRow fromOnly $ groupId_ <-
maybeFirstRow fromOnly $
DB.query DB.query
db db
[sql| [sql|
@ -1330,7 +1331,8 @@ getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSch
getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo) getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
groupId_ <- maybeFirstRow fromOnly $ groupId_ <-
maybeFirstRow fromOnly $
DB.query DB.query
db db
[sql| [sql|

View file

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

View file

@ -8,7 +8,6 @@
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Profiles module Simplex.Chat.Store.Profiles
@ -66,9 +65,9 @@ import Control.Monad.IO.Class
import qualified Data.Aeson.TH as J import qualified Data.Aeson.TH as J
import Data.Functor (($>)) import Data.Functor (($>))
import Data.Int (Int64) import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime (..), getCurrentTime) import Data.Time.Clock (UTCTime (..), getCurrentTime)
@ -89,7 +88,7 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Parsers (defaultJSON)
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode) import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode)
import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (safeDecodeUtf8, eitherToMaybe) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User
createUserRecord db auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime createUserRecord db auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime
@ -457,7 +456,8 @@ getUserContactLinkByConnReq db User {userId} (cReqSchema1, cReqSchema2) =
getContactWithoutConnViaAddress :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact) getContactWithoutConnViaAddress :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact)
getContactWithoutConnViaAddress db user@User {userId} (cReqSchema1, cReqSchema2) = do getContactWithoutConnViaAddress db user@User {userId} (cReqSchema1, cReqSchema2) = do
ctId_ <- maybeFirstRow fromOnly $ ctId_ <-
maybeFirstRow fromOnly $
DB.query DB.query
db db
[sql| [sql|

View file

@ -101,7 +101,7 @@ data StoreError
| SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId} | SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId}
| SEDuplicateGroupMessage {groupId :: Int64, sharedMsgId :: SharedMsgId, authorGroupMemberId :: Maybe GroupMemberId, forwardedByGroupMemberId :: Maybe GroupMemberId} | SEDuplicateGroupMessage {groupId :: Int64, sharedMsgId :: SharedMsgId, authorGroupMemberId :: Maybe GroupMemberId, forwardedByGroupMemberId :: Maybe GroupMemberId}
| SERemoteHostNotFound {remoteHostId :: RemoteHostId} | SERemoteHostNotFound {remoteHostId :: RemoteHostId}
| SERemoteHostUnknown -- ^ attempting to store KnownHost without a known fingerprint | SERemoteHostUnknown -- attempting to store KnownHost without a known fingerprint
| SERemoteHostDuplicateCA | SERemoteHostDuplicateCA
| SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId} | SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
| SERemoteCtrlDuplicateCA | SERemoteCtrlDuplicateCA

View file

@ -24,7 +24,7 @@ import Simplex.Chat (execChatCommand, processChatCommand)
import Simplex.Chat.Controller import Simplex.Chat.Controller
import Simplex.Chat.Markdown import Simplex.Chat.Markdown
import Simplex.Chat.Messages import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent (CIContent(..), SMsgDirection (..)) import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..))
import Simplex.Chat.Options import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..), msgContentText) import Simplex.Chat.Protocol (MsgContent (..), msgContentText)
import Simplex.Chat.Remote.Types (RHKey (..), RemoteHostId, RemoteHostInfo (..), RemoteHostSession (..)) import Simplex.Chat.Remote.Types (RHKey (..), RemoteHostId, RemoteHostInfo (..), RemoteHostSession (..))
@ -167,7 +167,8 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc
_ -> pure () _ -> pure ()
logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s
getRemoteUser rhId = runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case getRemoteUser rhId =
runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case
CRActiveUser {user} -> updateRemoteUser ct user rhId CRActiveUser {user} -> updateRemoteUser ct user rhId
cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr
removeRemoteUser rhId = atomically $ TM.delete rhId (currentRemoteUsers ct) removeRemoteUser rhId = atomically $ TM.delete rhId (currentRemoteUsers ct)

View file

@ -17,7 +17,6 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use newtype instead of data" #-} {-# HLINT ignore "Use newtype instead of data" #-}
@ -40,7 +39,7 @@ import qualified Data.Text as T
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Database.SQLite.Simple (ResultError (..), SQLData (..)) import Database.SQLite.Simple (ResultError (..), SQLData (..))
import Database.SQLite.Simple.FromField (returnError, FromField(..)) import Database.SQLite.Simple.FromField (FromField (..), returnError)
import Database.SQLite.Simple.Internal (Field (..)) import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok import Database.SQLite.Simple.Ok
import Database.SQLite.Simple.ToField (ToField (..)) import Database.SQLite.Simple.ToField (ToField (..))
@ -50,7 +49,7 @@ import Simplex.FileTransfer.Description (FileDigest)
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId) import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..)) import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON, enumJSON) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, sumTypeJSON, taggedObjectJSON)
import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI) import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
import Simplex.Messaging.Util ((<$?>)) import Simplex.Messaging.Util ((<$?>))
import Simplex.Messaging.Version import Simplex.Messaging.Version
@ -498,7 +497,7 @@ data LocalProfile = LocalProfile
deriving (Eq, Show) deriving (Eq, Show)
localProfileId :: LocalProfile -> ProfileId localProfileId :: LocalProfile -> ProfileId
localProfileId LocalProfile{profileId} = profileId localProfileId LocalProfile {profileId} = profileId
toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile
toLocalProfile profileId Profile {displayName, fullName, image, contactLink, preferences} localAlias = toLocalProfile profileId Profile {displayName, fullName, image, contactLink, preferences} localAlias =

View file

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

View file

@ -2,7 +2,7 @@
module Simplex.Chat.Types.Util where module Simplex.Chat.Types.Util where
import Data.Aeson (ToJSON, FromJSON) import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as J import qualified Data.Aeson as J
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.ByteString.Lazy.Char8 as LB

View file

@ -14,8 +14,8 @@ module Simplex.Chat.View where
import qualified Data.Aeson as J import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ import qualified Data.Aeson.TH as JQ
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (isSpace, toUpper) import Data.Char (isSpace, toUpper)
import Data.Function (on) import Data.Function (on)
@ -44,8 +44,8 @@ import Simplex.Chat.Markdown
import Simplex.Chat.Messages hiding (NewChatItem (..)) import Simplex.Chat.Messages hiding (NewChatItem (..))
import Simplex.Chat.Messages.CIContent import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Protocol import Simplex.Chat.Protocol
import Simplex.Chat.Remote.AppVersion (AppVersion (..), pattern AppVersionRange)
import Simplex.Chat.Remote.Types import Simplex.Chat.Remote.Types
import Simplex.Chat.Remote.AppVersion (pattern AppVersionRange, AppVersion (..))
import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..)) import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..))
import Simplex.Chat.Styled import Simplex.Chat.Styled
import Simplex.Chat.Types import Simplex.Chat.Types
@ -308,10 +308,10 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
<> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_ <> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_
CRRemoteCtrlList cs -> viewRemoteCtrls cs CRRemoteCtrlList cs -> viewRemoteCtrls cs
CRRemoteCtrlFound {remoteCtrl = RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName}, ctrlAppInfo_, appVersion, compatible} -> CRRemoteCtrlFound {remoteCtrl = RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName}, ctrlAppInfo_, appVersion, compatible} ->
[ "remote controller " <> sShow remoteCtrlId <> " found: " [ ("remote controller " <> sShow remoteCtrlId <> " found: ")
<> maybe (deviceName <> "not compatible") (\info -> viewRemoteCtrl info appVersion compatible) ctrlAppInfo_ <> maybe (deviceName <> "not compatible") (\info -> viewRemoteCtrl info appVersion compatible) ctrlAppInfo_
] ]
<> [ "use " <> highlight ("/confirm remote ctrl " <> show remoteCtrlId) <> " to connect" | isJust ctrlAppInfo_ && compatible] <> ["use " <> highlight ("/confirm remote ctrl " <> show remoteCtrlId) <> " to connect" | isJust ctrlAppInfo_ && compatible]
where where
deviceName = if T.null ctrlDeviceName then "" else plain ctrlDeviceName <> ", " deviceName = if T.null ctrlDeviceName then "" else plain ctrlDeviceName <> ", "
CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion} -> CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion} ->
@ -511,7 +511,9 @@ viewChats ts tz = concatMap chatPreview . reverse
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString] viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember}, content, quotedItem, file} doShow ts tz = viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember}, content, quotedItem, file} doShow ts tz =
withGroupMsgForwarded . withItemDeleted <$> (case chat of withGroupMsgForwarded . withItemDeleted <$> viewCI
where
viewCI = case chat of
DirectChat c -> case chatDir of DirectChat c -> case chatDir of
CIDirectSnd -> case content of CIDirectSnd -> case content of
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
@ -545,8 +547,7 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember},
from = ttyFromGroup g m from = ttyFromGroup g m
where where
quote = maybe [] (groupQuote g) quotedItem quote = maybe [] (groupQuote g) quotedItem
_ -> []) _ -> []
where
withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of
Nothing -> item Nothing -> item
Just t -> item <> styled (colored Red) (" [" <> t <> "]") Just t -> item <> styled (colored Red) (" [" <> t <> "]")
@ -788,7 +789,7 @@ viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of
viewContactsList :: [Contact] -> [StyledString] viewContactsList :: [Contact] -> [StyledString]
viewContactsList = viewContactsList =
let getLDN :: Contact -> ContactName let getLDN :: Contact -> ContactName
getLDN Contact{localDisplayName} = localDisplayName getLDN Contact {localDisplayName} = localDisplayName
ldn = T.toLower . getLDN ldn = T.toLower . getLDN
in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn
where where
@ -823,8 +824,8 @@ simplexChatContact (CRContactUri crData) = CRContactUri crData {crScheme = simpl
autoAcceptStatus_ :: Maybe AutoAccept -> [StyledString] autoAcceptStatus_ :: Maybe AutoAccept -> [StyledString]
autoAcceptStatus_ = \case autoAcceptStatus_ = \case
Just AutoAccept {acceptIncognito, autoReply} -> Just AutoAccept {acceptIncognito, autoReply} ->
("auto_accept on" <> if acceptIncognito then ", incognito" else "") : ("auto_accept on" <> if acceptIncognito then ", incognito" else "")
maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply : maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply
_ -> ["auto_accept off"] _ -> ["auto_accept off"]
groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> GroupMemberRole -> [StyledString] groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> GroupMemberRole -> [StyledString]
@ -907,8 +908,8 @@ viewJoinedGroupMember g m =
viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString] viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString]
viewReceivedGroupInvitation g c role = viewReceivedGroupInvitation g c role =
ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role) : ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role)
case incognitoMembershipProfile g of : case incognitoMembershipProfile g of
Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)] Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)]
Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"] Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"]
@ -996,13 +997,13 @@ viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs
GSMemRemoved -> delete "you are removed" GSMemRemoved -> delete "you are removed"
GSMemLeft -> delete "you left" GSMemLeft -> delete "you left"
GSMemGroupDeleted -> delete "group deleted" GSMemGroupDeleted -> delete "group deleted"
_ -> " (" <> memberCount <> _ -> " (" <> memberCount <> viewNtf <> ")"
case enableNtfs of where
MFAll -> ")" viewNtf = case enableNtfs of
MFAll -> ""
MFNone -> ", muted, " <> unmute MFNone -> ", muted, " <> unmute
MFMentions -> ", mentions only, " <> unmute MFMentions -> ", mentions only, " <> unmute
where unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g)
unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g) <> ")"
delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")" delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")"
memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s" memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s"
@ -1551,7 +1552,8 @@ receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIF
cfArgsStr (Just cfArgs) = [plain (cryptoFileArgsStr testView cfArgs) | status == "completed"] cfArgsStr (Just cfArgs) = [plain (cryptoFileArgsStr testView cfArgs) | status == "completed"]
cfArgsStr _ = [] cfArgsStr _ = []
getRemoteFileStr = case hu of getRemoteFileStr = case hu of
(Just rhId, Just User {userId}) | status == "completed" -> (Just rhId, Just User {userId})
| status == "completed" ->
[ "File received to connected remote host " <> sShow rhId, [ "File received to connected remote host " <> sShow rhId,
"To download to this device use:", "To download to this device use:",
highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f})) highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f}))
@ -1591,7 +1593,7 @@ viewFileTransferStatus (FTSnd FileTransferMeta {cancelled} fts@(ft : _), chunksN
[recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus] [recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus]
recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses
fs :: SndFileTransfer -> FileStatus fs :: SndFileTransfer -> FileStatus
fs SndFileTransfer{fileStatus} = fileStatus fs SndFileTransfer {fileStatus} = fileStatus
recipientsTransferStatus [] = [] recipientsTransferStatus [] = []
recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts] recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts]
where where
@ -1763,7 +1765,8 @@ viewChatError logLevel testView = \case
CEEmptyUserPassword _ -> ["user password is required"] CEEmptyUserPassword _ -> ["user password is required"]
CEUserAlreadyHidden _ -> ["user is already hidden"] CEUserAlreadyHidden _ -> ["user is already hidden"]
CEUserNotHidden _ -> ["user is not hidden"] CEUserNotHidden _ -> ["user is not hidden"]
CEInvalidDisplayName {displayName, validName} -> map plain $ CEInvalidDisplayName {displayName, validName} ->
map plain $
["invalid display name: " <> viewName displayName] ["invalid display name: " <> viewName displayName]
<> ["you could use this one: " <> viewName validName | not (T.null validName)] <> ["you could use this one: " <> viewName validName | not (T.null validName)]
CEChatNotStarted -> ["error: chat not started"] CEChatNotStarted -> ["error: chat not started"]

View file

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

View file

@ -259,7 +259,6 @@ testPlanInvitationLinkOk =
bob ##> ("/_connect plan 1 " <> inv) bob ##> ("/_connect plan 1 " <> inv)
bob <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection bob <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
alice <##> bob alice <##> bob
testPlanInvitationLinkOwn :: HasCallStack => FilePath -> IO () testPlanInvitationLinkOwn :: HasCallStack => FilePath -> IO ()
@ -283,7 +282,6 @@ testPlanInvitationLinkOwn tmp =
alice ##> ("/_connect plan 1 " <> inv) alice ##> ("/_connect plan 1 " <> inv)
alice <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection alice <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
alice @@@ [("@alice_1", lastChatFeature), ("@alice_2", lastChatFeature)] alice @@@ [("@alice_1", lastChatFeature), ("@alice_2", lastChatFeature)]
alice `send` "@alice_2 hi" alice `send` "@alice_2 hi"
alice alice
@ -1213,31 +1211,34 @@ testMuteGroup =
cath `send` "> #team (hello) hello too!" cath `send` "> #team (hello) hello too!"
cath <# "#team > bob hello" cath <# "#team > bob hello"
cath <## " hello too!" cath <## " hello too!"
concurrently_ concurrentlyN_
(bob </) [ (bob </),
( do alice <# "#team cath> > bob hello" do
alice <# "#team cath> > bob hello"
alice <## " hello too!" alice <## " hello too!"
) ]
bob ##> "/unmute mentions #team" bob ##> "/unmute mentions #team"
bob <## "ok" bob <## "ok"
alice `send` "> #team @bob (hello) hey bob!" alice `send` "> #team @bob (hello) hey bob!"
alice <# "#team > bob hello" alice <# "#team > bob hello"
alice <## " hey bob!" alice <## " hey bob!"
concurrently_ concurrentlyN_
( do bob <# "#team alice> > bob hello" [ do
bob <## " hey bob!" bob <# "#team alice> > bob hello"
) bob <## " hey bob!",
( do cath <# "#team alice> > bob hello" do
cath <# "#team alice> > bob hello"
cath <## " hey bob!" cath <## " hey bob!"
) ]
alice `send` "> #team @cath (hello) hey cath!" alice `send` "> #team @cath (hello) hey cath!"
alice <# "#team > cath hello too!" alice <# "#team > cath hello too!"
alice <## " hey cath!" alice <## " hey cath!"
concurrently_ concurrentlyN_
(bob </) [ (bob </),
( do cath <# "#team alice> > cath hello too!" do
cath <# "#team alice> > cath hello too!"
cath <## " hey cath!" cath <## " hey cath!"
) ]
bob ##> "/gs" bob ##> "/gs"
bob <## "#team (3 members, mentions only, you can /unmute #team)" bob <## "#team (3 members, mentions only, you can /unmute #team)"
bob ##> "/unmute #team" bob ##> "/unmute #team"

View file

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

View file

@ -7,7 +7,7 @@ import ChatClient
import ChatTests.Utils import ChatTests.Utils
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_) import Control.Concurrent.Async (concurrently_)
import Control.Monad (when, void) import Control.Monad (void, when)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import Data.List (isInfixOf) import Data.List (isInfixOf)
import qualified Data.Text as T import qualified Data.Text as T
@ -122,7 +122,8 @@ chatGroupTests = do
-- because host uses current code and sends version in MemberInfo -- because host uses current code and sends version in MemberInfo
testNoDirect vrMem2 vrMem3 noConns = testNoDirect vrMem2 vrMem3 noConns =
it it
( "host " <> vRangeStr supportedChatVRange ( "host "
<> vRangeStr supportedChatVRange
<> (", 2nd mem " <> vRangeStr vrMem2) <> (", 2nd mem " <> vRangeStr vrMem2)
<> (", 3rd mem " <> vRangeStr vrMem3) <> (", 3rd mem " <> vRangeStr vrMem3)
<> (if noConns then " : 2 <!!> 3" else " : 2 <##> 3") <> (if noConns then " : 2 <!!> 3" else " : 2 <##> 3")
@ -3859,11 +3860,9 @@ testMemberContactProfileUpdate =
bob #> "#team hello too" bob #> "#team hello too"
alice <# "#team rob> hello too" alice <# "#team rob> hello too"
cath <# "#team bob> hello too" -- not updated profile cath <# "#team bob> hello too" -- not updated profile
cath #> "#team hello there" cath #> "#team hello there"
alice <# "#team kate> hello there" alice <# "#team kate> hello there"
bob <# "#team cath> hello there" -- not updated profile bob <# "#team cath> hello there" -- not updated profile
bob `send` "@cath hi" bob `send` "@cath hi"
bob bob
<### [ "member #team cath does not have direct connection, creating", <### [ "member #team cath does not have direct connection, creating",
@ -3903,7 +3902,6 @@ testMemberContactProfileUpdate =
bob #> "#team hello too" bob #> "#team hello too"
alice <# "#team rob> hello too" alice <# "#team rob> hello too"
cath <# "#team rob> hello too" -- updated profile cath <# "#team rob> hello too" -- updated profile
cath #> "#team hello there" cath #> "#team hello there"
alice <# "#team kate> hello there" alice <# "#team kate> hello there"
bob <# "#team kate> hello there" -- updated profile bob <# "#team kate> hello there" -- updated profile
@ -3941,7 +3939,6 @@ setupGroupForwarding3 gName alice bob cath = do
createGroup3 gName alice bob cath createGroup3 gName alice bob cath
threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected
void $ withCCTransaction bob $ \db -> void $ withCCTransaction bob $ \db ->
DB.execute_ db "UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3" DB.execute_ db "UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3"
void $ withCCTransaction cath $ \db -> void $ withCCTransaction cath $ \db ->
@ -3956,7 +3953,6 @@ testGroupMsgForwardDeduplicate =
createGroup3 "team" alice bob cath createGroup3 "team" alice bob cath
threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected
void $ withCCTransaction alice $ \db -> void $ withCCTransaction alice $ \db ->
DB.execute_ db "UPDATE group_member_intros SET intro_status='fwd'" DB.execute_ db "UPDATE group_member_intros SET intro_status='fwd'"
@ -4001,7 +3997,6 @@ testGroupMsgForwardEdit =
bob <# "#team [edited] hello there" bob <# "#team [edited] hello there"
alice <# "#team bob> [edited] hello there" alice <# "#team bob> [edited] hello there"
cath <# "#team bob> [edited] hello there" -- TODO show as forwarded cath <# "#team bob> [edited] hello there" -- TODO show as forwarded
alice ##> "/tail #team 1" alice ##> "/tail #team 1"
alice <# "#team bob> hello there" alice <# "#team bob> hello there"

View file

@ -7,16 +7,16 @@ import ChatClient
import ChatTests.Utils import ChatTests.Utils
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_) import Control.Concurrent.Async (concurrently_)
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T import qualified Data.Text as T
import Simplex.Chat.Store.Shared (createContact)
import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..), Profile (..)) import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..), Profile (..))
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import System.Directory (copyFile, createDirectoryIfMissing) import System.Directory (copyFile, createDirectoryIfMissing)
import Test.Hspec import Test.Hspec
import Simplex.Chat.Store.Shared (createContact)
import Control.Monad
import Simplex.Messaging.Encoding.String (StrEncoding(..))
chatProfileTests :: SpecWith FilePath chatProfileTests :: SpecWith FilePath
chatProfileTests = do chatProfileTests = do
@ -633,7 +633,7 @@ testPlanAddressOwn tmp =
alice <## "alice_1 (Alice) wants to connect to you!" alice <## "alice_1 (Alice) wants to connect to you!"
alice <## "to accept: /ac alice_1" alice <## "to accept: /ac alice_1"
alice <## "to reject: /rc alice_1 (the sender will NOT be notified)" alice <## "to reject: /rc alice_1 (the sender will NOT be notified)"
alice @@@ [("<@alice_1", ""), (":2","")] alice @@@ [("<@alice_1", ""), (":2", "")]
alice ##> "/ac alice_1" alice ##> "/ac alice_1"
alice <## "alice_1 (Alice): accepting contact request..." alice <## "alice_1 (Alice): accepting contact request..."
alice alice

View file

@ -310,7 +310,7 @@ getInAnyOrder f cc ls = do
Predicate p -> p l Predicate p -> p l
filterFirst :: (a -> Bool) -> [a] -> [a] filterFirst :: (a -> Bool) -> [a] -> [a]
filterFirst _ [] = [] filterFirst _ [] = []
filterFirst p (x:xs) filterFirst p (x : xs)
| p x = xs | p x = xs
| otherwise = x : filterFirst p xs | otherwise = x : filterFirst p xs

View file

@ -13,8 +13,8 @@ import RemoteTests
import SchemaDump import SchemaDump
import Test.Hspec import Test.Hspec
import UnliftIO.Temporary (withTempDirectory) import UnliftIO.Temporary (withTempDirectory)
import ViewTests
import ValidNames import ValidNames
import ViewTests
import WebRTCTests import WebRTCTests
main :: IO () main :: IO ()