mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
core: use fourmolu styles (#3470)
This commit is contained in:
parent
75c2de8a12
commit
d29f1bb0cf
43 changed files with 902 additions and 865 deletions
30
fourmolu.yaml
Normal file
30
fourmolu.yaml
Normal file
|
@ -0,0 +1,30 @@
|
|||
indentation: 2
|
||||
column-limit: none
|
||||
function-arrows: trailing
|
||||
comma-style: trailing
|
||||
import-export-style: trailing
|
||||
indent-wheres: true
|
||||
record-brace-space: true
|
||||
newlines-between-decls: 1
|
||||
haddock-style: single-line
|
||||
haddock-style-module: null
|
||||
let-style: inline
|
||||
in-style: right-align
|
||||
single-constraint-parens: never
|
||||
unicode: never
|
||||
respectful: true
|
||||
fixities:
|
||||
- infixr 9 .
|
||||
- infixr 8 .:, .:., .=
|
||||
- infixr 6 <>
|
||||
- infixr 5 ++
|
||||
- infixl 4 <$>, <$, $>, <$$>, <$?>
|
||||
- infixl 4 <*>, <*, *>, <**>
|
||||
- infix 4 ==, /=
|
||||
- infixr 3 &&
|
||||
- infixl 3 <|>
|
||||
- infixr 2 ||
|
||||
- infixl 1 >>, >>=
|
||||
- infixr 1 =<<, >=>, <=<
|
||||
- infixr 0 $, $!
|
||||
reexports: []
|
File diff suppressed because one or more lines are too long
|
@ -22,7 +22,7 @@ import qualified Data.Text as T
|
|||
import qualified Database.SQLite3 as SQL
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Messaging.Agent.Client (agentClientStore)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), sqlString, closeSQLiteStore)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), closeSQLiteStore, sqlString)
|
||||
import Simplex.Messaging.Util
|
||||
import System.FilePath
|
||||
import UnliftIO.Directory
|
||||
|
|
|
@ -6,8 +6,8 @@ module Simplex.Chat.Bot.KnownContacts where
|
|||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Options.Applicative
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||
|
|
|
@ -225,4 +225,3 @@ instance FromField CallState where
|
|||
fromField = fromTextField_ decodeJSON
|
||||
|
||||
$(J.deriveJSON defaultJSON ''RcvCallInvitation)
|
||||
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
@ -426,19 +426,19 @@ data ChatCommand
|
|||
| SetGroupTimedMessages GroupName (Maybe Int)
|
||||
| SetLocalDeviceName Text
|
||||
| ListRemoteHosts
|
||||
| StartRemoteHost (Maybe (RemoteHostId, Bool)) -- ^ Start new or known remote host with optional multicast for known host
|
||||
| SwitchRemoteHost (Maybe RemoteHostId) -- ^ Switch current remote host
|
||||
| StopRemoteHost RHKey -- ^ Shut down a running session
|
||||
| DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data
|
||||
| StartRemoteHost (Maybe (RemoteHostId, Bool)) -- Start new or known remote host with optional multicast for known host
|
||||
| SwitchRemoteHost (Maybe RemoteHostId) -- Switch current remote host
|
||||
| StopRemoteHost RHKey -- Shut down a running session
|
||||
| DeleteRemoteHost RemoteHostId -- Unregister remote host and remove its data
|
||||
| StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath}
|
||||
| GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile}
|
||||
| ConnectRemoteCtrl RCSignedInvitation -- ^ Connect new or existing controller via OOB data
|
||||
| FindKnownRemoteCtrl -- ^ Start listening for announcements from all existing controllers
|
||||
| ConfirmRemoteCtrl RemoteCtrlId -- ^ Confirm the connection with found controller
|
||||
| VerifyRemoteCtrlSession Text -- ^ Verify remote controller session
|
||||
| ConnectRemoteCtrl RCSignedInvitation -- Connect new or existing controller via OOB data
|
||||
| FindKnownRemoteCtrl -- Start listening for announcements from all existing controllers
|
||||
| ConfirmRemoteCtrl RemoteCtrlId -- Confirm the connection with found controller
|
||||
| VerifyRemoteCtrlSession Text -- Verify remote controller session
|
||||
| ListRemoteCtrls
|
||||
| StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session
|
||||
| DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a remote controller session
|
||||
| StopRemoteCtrl -- Stop listening for announcements or terminate an active session
|
||||
| DeleteRemoteCtrl RemoteCtrlId -- Remove all local data associated with a remote controller session
|
||||
| QuitChat
|
||||
| ShowVersion
|
||||
| DebugLocks
|
||||
|
@ -1072,13 +1072,13 @@ throwDBError = throwError . ChatErrorDatabase
|
|||
|
||||
-- TODO review errors, some of it can be covered by HTTP2 errors
|
||||
data RemoteHostError
|
||||
= RHEMissing -- ^ No remote session matches this identifier
|
||||
| RHEInactive -- ^ A session exists, but not active
|
||||
| RHEBusy -- ^ A session is already running
|
||||
= RHEMissing -- No remote session matches this identifier
|
||||
| RHEInactive -- A session exists, but not active
|
||||
| RHEBusy -- A session is already running
|
||||
| RHETimeout
|
||||
| RHEBadState -- ^ Illegal state transition
|
||||
| RHEBadState -- Illegal state transition
|
||||
| RHEBadVersion {appVersion :: AppVersion}
|
||||
| RHELocalCommand -- ^ Command not allowed for remote execution
|
||||
| RHELocalCommand -- Command not allowed for remote execution
|
||||
| RHEDisconnected {reason :: Text} -- TODO should be sent when disconnected?
|
||||
| RHEProtocolError RemoteProtocolError
|
||||
deriving (Show, Exception)
|
||||
|
@ -1091,13 +1091,14 @@ data RemoteHostStopReason
|
|||
|
||||
-- TODO review errors, some of it can be covered by HTTP2 errors
|
||||
data RemoteCtrlError
|
||||
= RCEInactive -- ^ No session is running
|
||||
| RCEBadState -- ^ A session is in a wrong state for the current operation
|
||||
| RCEBusy -- ^ A session is already running
|
||||
= RCEInactive -- No session is running
|
||||
| RCEBadState -- A session is in a wrong state for the current operation
|
||||
| RCEBusy -- A session is already running
|
||||
| RCETimeout
|
||||
| RCENoKnownControllers -- ^ No previously-contacted controllers to discover
|
||||
| RCEBadController -- ^ Attempting to confirm a found controller with another ID
|
||||
| RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected by a controller
|
||||
| RCENoKnownControllers -- No previously-contacted controllers to discover
|
||||
| RCEBadController -- Attempting to confirm a found controller with another ID
|
||||
| -- | A session disconnected by a controller
|
||||
RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text}
|
||||
| RCEBadInvitation
|
||||
| RCEBadVersion {appVersion :: AppVersion}
|
||||
| RCEHTTP2Error {http2Error :: Text} -- TODO currently not used
|
||||
|
@ -1223,8 +1224,8 @@ toView event = do
|
|||
session <- asks remoteCtrlSession
|
||||
atomically $
|
||||
readTVar session >>= \case
|
||||
Just (_, RCSessionConnected {remoteOutputQ}) | allowRemoteEvent event ->
|
||||
writeTBQueue remoteOutputQ event
|
||||
Just (_, RCSessionConnected {remoteOutputQ})
|
||||
| allowRemoteEvent event -> writeTBQueue remoteOutputQ event
|
||||
-- TODO potentially, it should hold some events while connecting
|
||||
_ -> writeTBQueue localQ (Nothing, Nothing, event)
|
||||
|
||||
|
|
|
@ -6,8 +6,8 @@ module Simplex.Chat.Files where
|
|||
import Control.Monad.IO.Class
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Messaging.Util (ifM)
|
||||
import System.FilePath (splitExtensions, combine)
|
||||
import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, getHomeDirectory, doesDirectoryExist)
|
||||
import System.FilePath (combine, splitExtensions)
|
||||
import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getHomeDirectory, getTemporaryDirectory)
|
||||
|
||||
uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
|
||||
uniqueCombine fPath fName = tryCombine (0 :: Int)
|
||||
|
|
|
@ -19,7 +19,7 @@ import qualified Data.Attoparsec.Text as A
|
|||
import Data.Char (isDigit, isPunctuation)
|
||||
import Data.Either (fromRight)
|
||||
import Data.Functor (($>))
|
||||
import Data.List (intercalate, foldl')
|
||||
import Data.List (foldl', intercalate)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (fromMaybe, isNothing)
|
||||
|
@ -85,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
|
||||
|
|
|
@ -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, (<$?>))
|
||||
|
||||
|
|
|
@ -311,7 +311,7 @@ profileToText Profile {displayName, fullName} = displayName <> optionalFullName
|
|||
msgIntegrityError :: MsgErrorType -> Text
|
||||
msgIntegrityError = \case
|
||||
MsgSkipped fromId toId ->
|
||||
"skipped message ID " <> tshow fromId
|
||||
("skipped message ID " <> tshow fromId)
|
||||
<> if fromId == toId then "" else ".." <> tshow toId
|
||||
MsgBadId msgId -> "unexpected message ID " <> tshow msgId
|
||||
MsgBadHash -> "incorrect message hash"
|
||||
|
|
|
@ -46,8 +46,8 @@ data SndConnEvent
|
|||
| SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef}
|
||||
deriving (Show)
|
||||
|
||||
data RcvDirectEvent =
|
||||
-- RDEProfileChanged {...}
|
||||
data RcvDirectEvent
|
||||
= -- RDEProfileChanged {...}
|
||||
RDEContactDeleted
|
||||
deriving (Show)
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -6,8 +6,8 @@ import qualified Data.ByteString as B
|
|||
import Data.ByteString.Internal (ByteString (..), memcpy)
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import qualified Data.ByteString.Lazy.Internal as LB
|
||||
import Foreign.C (CInt, CString)
|
||||
import Foreign
|
||||
import Foreign.C (CInt, CString)
|
||||
|
||||
type CJSONString = CString
|
||||
|
||||
|
|
|
@ -1,12 +1,12 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module Simplex.Chat.Mobile.WebRTC (
|
||||
cChatEncryptMedia,
|
||||
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
|
||||
|
|
|
@ -13,7 +13,6 @@
|
|||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Chat.Protocol where
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -11,7 +11,7 @@ module Simplex.Chat.Remote.AppVersion
|
|||
compatibleAppVersion,
|
||||
isAppCompatible,
|
||||
)
|
||||
where
|
||||
where
|
||||
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson as J
|
||||
|
|
|
@ -6,10 +6,8 @@ import Network.Socket
|
|||
|
||||
#include <HsNet.h>
|
||||
|
||||
{- | Toggle multicast group membership.
|
||||
|
||||
NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups.
|
||||
-}
|
||||
-- | Toggle multicast group membership.
|
||||
-- NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups.
|
||||
setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ())
|
||||
setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do
|
||||
#{poke struct ip_mreq, imr_multiaddr} mReqPtr group
|
||||
|
|
|
@ -6,8 +6,8 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.Chat.Remote.Protocol where
|
||||
|
||||
|
@ -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
|
||||
|
|
|
@ -5,15 +5,15 @@ module Simplex.Chat.Remote.Transport where
|
|||
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Data.ByteString.Builder (Builder, byteString)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString.Builder (Builder, byteString)
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Word (Word32)
|
||||
import Simplex.FileTransfer.Description (FileDigest (..))
|
||||
import Simplex.Chat.Remote.Types
|
||||
import Simplex.FileTransfer.Description (FileDigest (..))
|
||||
import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sendEncFile)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sendEncFile)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Util (liftEitherError, liftEitherWith)
|
||||
import Simplex.RemoteControl.Types (RCErrorType (..))
|
||||
|
|
|
@ -21,13 +21,13 @@ import Data.Text (Text)
|
|||
import Simplex.Chat.Remote.AppVersion
|
||||
import Simplex.Chat.Types (verificationCode)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile)
|
||||
import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret)
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
|
||||
import Simplex.Messaging.Transport (TLS (..))
|
||||
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
|
||||
import Simplex.RemoteControl.Client
|
||||
import Simplex.RemoteControl.Types
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile)
|
||||
import Simplex.Messaging.Transport (TLS (..))
|
||||
|
||||
data RemoteHostClient = RemoteHostClient
|
||||
{ hostEncoding :: PlatformEncoding,
|
||||
|
|
|
@ -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|
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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|
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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|
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -17,7 +17,6 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilyDependencies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
|
||||
{-# HLINT ignore "Use newtype instead of data" #-}
|
||||
|
@ -40,7 +39,7 @@ import qualified Data.Text as T
|
|||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Typeable (Typeable)
|
||||
import Database.SQLite.Simple (ResultError (..), SQLData (..))
|
||||
import Database.SQLite.Simple.FromField (returnError, FromField(..))
|
||||
import Database.SQLite.Simple.FromField (FromField (..), returnError)
|
||||
import Database.SQLite.Simple.Internal (Field (..))
|
||||
import Database.SQLite.Simple.Ok
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
|
@ -50,7 +49,7 @@ import Simplex.FileTransfer.Description (FileDigest)
|
|||
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
|
||||
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON, enumJSON)
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, sumTypeJSON, taggedObjectJSON)
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
import Simplex.Messaging.Version
|
||||
|
@ -498,7 +497,7 @@ data LocalProfile = LocalProfile
|
|||
deriving (Eq, Show)
|
||||
|
||||
localProfileId :: LocalProfile -> ProfileId
|
||||
localProfileId LocalProfile{profileId} = profileId
|
||||
localProfileId LocalProfile {profileId} = profileId
|
||||
|
||||
toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile
|
||||
toLocalProfile profileId Profile {displayName, fullName, image, contactLink, preferences} localAlias =
|
||||
|
|
|
@ -14,7 +14,6 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilyDependencies #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
module Simplex.Chat.Types.Util where
|
||||
|
||||
import Data.Aeson (ToJSON, FromJSON)
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
|
|
|
@ -14,8 +14,8 @@ module Simplex.Chat.View where
|
|||
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.TH as JQ
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Char (isSpace, toUpper)
|
||||
import Data.Function (on)
|
||||
|
@ -44,8 +44,8 @@ import Simplex.Chat.Markdown
|
|||
import Simplex.Chat.Messages hiding (NewChatItem (..))
|
||||
import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Remote.AppVersion (AppVersion (..), pattern AppVersionRange)
|
||||
import Simplex.Chat.Remote.Types
|
||||
import Simplex.Chat.Remote.AppVersion (pattern AppVersionRange, AppVersion (..))
|
||||
import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..))
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Types
|
||||
|
@ -308,10 +308,10 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
|||
<> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_
|
||||
CRRemoteCtrlList cs -> viewRemoteCtrls cs
|
||||
CRRemoteCtrlFound {remoteCtrl = RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName}, ctrlAppInfo_, appVersion, compatible} ->
|
||||
[ "remote controller " <> sShow remoteCtrlId <> " found: "
|
||||
[ ("remote controller " <> sShow remoteCtrlId <> " found: ")
|
||||
<> maybe (deviceName <> "not compatible") (\info -> viewRemoteCtrl info appVersion compatible) ctrlAppInfo_
|
||||
]
|
||||
<> [ "use " <> highlight ("/confirm remote ctrl " <> show remoteCtrlId) <> " to connect" | isJust ctrlAppInfo_ && compatible]
|
||||
<> ["use " <> highlight ("/confirm remote ctrl " <> show remoteCtrlId) <> " to connect" | isJust ctrlAppInfo_ && compatible]
|
||||
where
|
||||
deviceName = if T.null ctrlDeviceName then "" else plain ctrlDeviceName <> ", "
|
||||
CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion} ->
|
||||
|
@ -511,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"]
|
||||
|
|
|
@ -5,7 +5,6 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module ChatClient where
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -1,7 +1,6 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PostfixOperators #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module ChatTests.Files where
|
||||
|
|
|
@ -7,7 +7,7 @@ import ChatClient
|
|||
import ChatTests.Utils
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (concurrently_)
|
||||
import Control.Monad (when, void)
|
||||
import Control.Monad (void, when)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.List (isInfixOf)
|
||||
import qualified Data.Text as T
|
||||
|
@ -122,7 +122,8 @@ chatGroupTests = do
|
|||
-- because host uses current code and sends version in MemberInfo
|
||||
testNoDirect vrMem2 vrMem3 noConns =
|
||||
it
|
||||
( "host " <> vRangeStr supportedChatVRange
|
||||
( "host "
|
||||
<> vRangeStr supportedChatVRange
|
||||
<> (", 2nd mem " <> vRangeStr vrMem2)
|
||||
<> (", 3rd mem " <> vRangeStr vrMem3)
|
||||
<> (if noConns then " : 2 <!!> 3" else " : 2 <##> 3")
|
||||
|
@ -3859,11 +3860,9 @@ testMemberContactProfileUpdate =
|
|||
bob #> "#team hello too"
|
||||
alice <# "#team rob> hello too"
|
||||
cath <# "#team bob> hello too" -- not updated profile
|
||||
|
||||
cath #> "#team hello there"
|
||||
alice <# "#team kate> hello there"
|
||||
bob <# "#team cath> hello there" -- not updated profile
|
||||
|
||||
bob `send` "@cath hi"
|
||||
bob
|
||||
<### [ "member #team cath does not have direct connection, creating",
|
||||
|
@ -3903,7 +3902,6 @@ testMemberContactProfileUpdate =
|
|||
bob #> "#team hello too"
|
||||
alice <# "#team rob> hello too"
|
||||
cath <# "#team rob> hello too" -- updated profile
|
||||
|
||||
cath #> "#team hello there"
|
||||
alice <# "#team kate> hello there"
|
||||
bob <# "#team kate> hello there" -- updated profile
|
||||
|
@ -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"
|
||||
|
||||
|
|
|
@ -7,16 +7,16 @@ import ChatClient
|
|||
import ChatTests.Utils
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (concurrently_)
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Store.Shared (createContact)
|
||||
import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..), Profile (..))
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||
import System.Directory (copyFile, createDirectoryIfMissing)
|
||||
import Test.Hspec
|
||||
import Simplex.Chat.Store.Shared (createContact)
|
||||
import Control.Monad
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding(..))
|
||||
|
||||
chatProfileTests :: SpecWith FilePath
|
||||
chatProfileTests = do
|
||||
|
@ -633,7 +633,7 @@ testPlanAddressOwn tmp =
|
|||
alice <## "alice_1 (Alice) wants to connect to you!"
|
||||
alice <## "to accept: /ac alice_1"
|
||||
alice <## "to reject: /rc alice_1 (the sender will NOT be notified)"
|
||||
alice @@@ [("<@alice_1", ""), (":2","")]
|
||||
alice @@@ [("<@alice_1", ""), (":2", "")]
|
||||
alice ##> "/ac alice_1"
|
||||
alice <## "alice_1 (Alice): accepting contact request..."
|
||||
alice
|
||||
|
|
|
@ -310,7 +310,7 @@ getInAnyOrder f cc ls = do
|
|||
Predicate p -> p l
|
||||
filterFirst :: (a -> Bool) -> [a] -> [a]
|
||||
filterFirst _ [] = []
|
||||
filterFirst p (x:xs)
|
||||
filterFirst p (x : xs)
|
||||
| p x = xs
|
||||
| otherwise = x : filterFirst p xs
|
||||
|
||||
|
|
|
@ -13,8 +13,8 @@ import RemoteTests
|
|||
import SchemaDump
|
||||
import Test.Hspec
|
||||
import UnliftIO.Temporary (withTempDirectory)
|
||||
import ViewTests
|
||||
import ValidNames
|
||||
import ViewTests
|
||||
import WebRTCTests
|
||||
|
||||
main :: IO ()
|
||||
|
|
Loading…
Add table
Reference in a new issue