diff --git a/apps/multiplatform/common/src/desktopMain/kotlin/chat/simplex/common/DesktopApp.kt b/apps/multiplatform/common/src/desktopMain/kotlin/chat/simplex/common/DesktopApp.kt index 1a95317a6..33453f5e8 100644 --- a/apps/multiplatform/common/src/desktopMain/kotlin/chat/simplex/common/DesktopApp.kt +++ b/apps/multiplatform/common/src/desktopMain/kotlin/chat/simplex/common/DesktopApp.kt @@ -124,7 +124,7 @@ fun showApp() = application { var hiddenUntilRestart by remember { mutableStateOf(false) } if (!hiddenUntilRestart) { val cWindowState = rememberWindowState(placement = WindowPlacement.Floating, width = DEFAULT_START_MODAL_WIDTH, height = 768.dp) - Window(state = cWindowState, onCloseRequest = ::exitApplication, title = stringResource(MR.strings.chat_console)) { + Window(state = cWindowState, onCloseRequest = { hiddenUntilRestart = true }, title = stringResource(MR.strings.chat_console)) { SimpleXTheme { TerminalView(ChatModel) { hiddenUntilRestart = true } } diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 000000000..907a25e7d --- /dev/null +++ b/fourmolu.yaml @@ -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: [] diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index f9eecac67..9d48e63d4 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -11,6 +11,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat where @@ -101,7 +102,7 @@ import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport.Client (defaultSocksProxy) import Simplex.Messaging.Util import Simplex.Messaging.Version -import Simplex.RemoteControl.Invitation (RCSignedInvitation (..), RCInvitation (..)) +import Simplex.RemoteControl.Invitation (RCInvitation (..), RCSignedInvitation (..)) import System.Exit (ExitCode, exitFailure, exitSuccess) import System.FilePath (takeFileName, ()) import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, stdout) @@ -109,8 +110,8 @@ import System.Random (randomRIO) import Text.Read (readMaybe) import UnliftIO.Async import UnliftIO.Concurrent (forkFinally, forkIO, mkWeakThreadId, threadDelay) -import qualified UnliftIO.Exception as E import UnliftIO.Directory +import qualified UnliftIO.Exception as E import UnliftIO.IO (hClose, hSeek, hTell, openFile) import UnliftIO.STM @@ -231,8 +232,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen contactMergeEnabled <- newTVarIO True pure ChatController - { - firstTime, + { firstTime, currentUser, currentRemoteHost, smpAgent, @@ -441,7 +441,7 @@ processChatCommand = \case [] -> pure 1 users -> do when (any (\User {localDisplayName = n} -> n == displayName) users) $ - throwChatError $ CEUserExists displayName + throwChatError (CEUserExists displayName) withAgent (\a -> createUser a smp xftp) ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure user <- withStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts @@ -464,8 +464,8 @@ processChatCommand = \case defServers <- asks $ defaultServers . config pure (cfgServers protocol defServers, []) storeServers user servers = - unless (null servers) $ - withStore $ \db -> overwriteProtocolServers db user servers + unless (null servers) . withStore $ + \db -> overwriteProtocolServers db user servers coupleDaysAgo t = (`addUTCTime` t) . fromInteger . negate . (+ (2 * day)) <$> randomRIO (0, day) day = 86400 ListUsers -> CRUsersList <$> withStoreCtx' (Just "ListUsers, getUsersInfo") getUsersInfo @@ -775,7 +775,9 @@ processChatCommand = \case MCVoice {} -> False MCUnknown {} -> True qText = msgContentText qmc - qFileName = maybe qText (T.pack . (fileName :: CIFile d -> String)) ciFile_ + getFileName :: CIFile d -> String + getFileName CIFile {fileName} = fileName + qFileName = maybe qText (T.pack . getFileName) ciFile_ qTextOrFile = if T.null qText then qFileName else qText xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup = do @@ -798,7 +800,8 @@ processChatCommand = \case -- we are not sending files to pending members, same as with inline files saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} = when ((connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn)) $ - withStore' $ \db -> createSndFTDescrXFTP db user (Just m) conn ft fileDescr + withStore' $ + \db -> createSndFTDescrXFTP db user (Just m) conn ft fileDescr saveMemberFD _ = pure () pure (fInv, ciFile, ft) unzipMaybe3 :: Maybe (a, b, c) -> (Maybe a, Maybe b, Maybe c) @@ -890,9 +893,9 @@ processChatCommand = \case withStore (\db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId) >>= \case (ct, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do unless (featureAllowed SCFReactions forUser ct) $ - throwChatError $ CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions) + throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)) unless (ciReactionAllowed ci) $ - throwChatError $ CECommandError "reaction not allowed - chat item has no content" + throwChatError (CECommandError "reaction not allowed - chat item has no content") rs <- withStore' $ \db -> getDirectReactions db ct itemSharedMId True checkReactionAllowed rs (SndMessage {msgId}, _) <- sendDirectContactMessage ct $ XMsgReact itemSharedMId Nothing reaction add @@ -908,9 +911,9 @@ processChatCommand = \case withStore (\db -> (,) <$> getGroup db user chatId <*> getGroupChatItem db user chatId itemId) >>= \case (Group g@GroupInfo {membership} ms, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do unless (groupFeatureAllowed SGFReactions g) $ - throwChatError $ CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions) + throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)) unless (ciReactionAllowed ci) $ - throwChatError $ CECommandError "reaction not allowed - chat item has no content" + throwChatError (CECommandError "reaction not allowed - chat item has no content") let GroupMember {memberId = itemMemberId} = chatItemMember g ci rs <- withStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True checkReactionAllowed rs @@ -928,9 +931,9 @@ processChatCommand = \case where checkReactionAllowed rs = do when ((reaction `elem` rs) == add) $ - throwChatError $ CECommandError $ "reaction already " <> if add then "added" else "removed" + throwChatError (CECommandError $ "reaction already " <> if add then "added" else "removed") when (add && length rs >= maxMsgReactions) $ - throwChatError $ CECommandError "too many reactions" + throwChatError (CECommandError "too many reactions") APIChatRead (ChatRef cType chatId) fromToIds -> withUser $ \_ -> case cType of CTDirect -> do user <- withStore $ \db -> getUserByContactId db chatId @@ -1167,7 +1170,9 @@ processChatCommand = \case APIGetNtfMessage nonce encNtfInfo -> withUser $ \_ -> do (NotificationInfo {ntfConnId, ntfMsgMeta}, msgs) <- withAgent $ \a -> getNotificationMessage a nonce encNtfInfo let ntfMessages = map (\SMP.SMPMsgMeta {msgTs, msgFlags} -> NtfMsgInfo {msgTs = systemToUTCTime msgTs, msgFlags}) msgs - msgTs' = systemToUTCTime . (SMP.msgTs :: SMP.NMsgMeta -> SystemTime) <$> ntfMsgMeta + getMsgTs :: SMP.NMsgMeta -> SystemTime + getMsgTs SMP.NMsgMeta {msgTs} = msgTs + msgTs' = systemToUTCTime . getMsgTs <$> ntfMsgMeta agentConnId = AgentConnId ntfConnId user_ <- withStore' (`getUserByAConnId` agentConnId) connEntity <- @@ -1247,9 +1252,10 @@ processChatCommand = \case m <- withStore $ \db -> do liftIO $ updateGroupMemberSettings db user gId gMemberId settings getGroupMember db user gId gMemberId - when (memberActive m) $ forM_ (memberConnId m) $ \connId -> do - let ntfOn = showMessages $ memberSettings m - withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` (toView . CRChatError (Just user)) + when (memberActive m) $ + forM_ (memberConnId m) $ \connId -> do + let ntfOn = showMessages $ memberSettings m + withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` (toView . CRChatError (Just user)) ok user APIContactInfo contactId -> withUser $ \user@User {userId} -> do -- [incognito] print user's incognito profile for this contact @@ -1414,8 +1420,9 @@ processChatCommand = \case case conn'_ of Just conn' -> pure $ CRConnectionIncognitoUpdated user conn' Nothing -> throwChatError CEConnectionIncognitoChangeProhibited - APIConnectPlan userId cReqUri -> withUserId userId $ \user -> withChatLock "connectPlan" . procCmd $ - CRConnectionPlan user <$> connectPlan user cReqUri + APIConnectPlan userId cReqUri -> withUserId userId $ \user -> + withChatLock "connectPlan" . procCmd $ + CRConnectionPlan user <$> connectPlan user cReqUri APIConnect userId incognito (Just (ACR SCMInvitation cReq)) -> withUserId userId $ \user -> withChatLock "connect" . procCmd $ do subMode <- chatReadVar subscriptionMode -- [incognito] generate profile to send @@ -2345,12 +2352,12 @@ processChatCommand = \case let Connection {connStatus, contactConnInitiated} = conn if | connStatus == ConnNew && contactConnInitiated -> - pure $ CPInvitationLink ILPOwnLink + pure $ CPInvitationLink ILPOwnLink | not (connReady conn) -> - pure $ CPInvitationLink (ILPConnecting ct_) + pure $ CPInvitationLink (ILPConnecting ct_) | otherwise -> case ct_ of - Just ct -> pure $ CPInvitationLink (ILPKnown ct) - Nothing -> throwChatError $ CEInternalError "ready RcvDirectMsgConnection connection should have associated contact" + Just ct -> pure $ CPInvitationLink (ILPKnown ct) + Nothing -> throwChatError $ CEInternalError "ready RcvDirectMsgConnection connection should have associated contact" Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection" where cReqSchemas :: (ConnReqInvitation, ConnReqInvitation) @@ -2396,7 +2403,7 @@ processChatCommand = \case (Nothing, Just _) -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection" (Just gInfo@GroupInfo {membership}, _) | not (memberActive membership) && not (memberRemoved membership) -> - pure $ CPGroupLink (GLPConnectingProhibit gInfo_) + pure $ CPGroupLink (GLPConnectingProhibit gInfo_) | memberActive membership -> pure $ CPGroupLink (GLPKnown gInfo) | otherwise -> pure $ CPGroupLink GLPOk where @@ -2414,7 +2421,7 @@ processChatCommand = \case assertDirectAllowed :: ChatMonad m => User -> MsgDirection -> Contact -> CMEventTag e -> m () assertDirectAllowed user dir ct event = unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $ - throwChatError $ CEDirectMessagesProhibited dir ct + throwChatError (CEDirectMessagesProhibited dir ct) where directMessagesAllowed = any (groupFeatureAllowed' SGFDirectMessages) <$> withStore' (\db -> getContactGroupPreferences db user ct) allowedChatEvent = case event of @@ -2631,7 +2638,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI rcvInline_ /= Just False && fileInline == Just IFMOffer && ( fileSize <= fileChunkSize * receiveChunks - || (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks) + || (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks) ) receiveViaCompleteFD :: ChatMonad m => User -> FileTransferId -> RcvFileDescr -> Maybe CryptoFileArgs -> m () @@ -2787,7 +2794,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do rs <- withAgent $ \a -> agentBatchSubscribe a conns -- send connection events to view contactSubsToView rs cts ce --- TODO possibly, we could either disable these events or replace with less noisy for API + -- TODO possibly, we could either disable these events or replace with less noisy for API contactLinkSubsToView rs ucs groupSubsToView rs gs ms ce sndFileSubsToView rs sfts @@ -2858,13 +2865,13 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do toView . CRContactSubSummary user $ map (uncurry ContactSubStatus) cRs when ce $ mapM_ (toView . uncurry (CRContactSubError user)) cErrors notifyAPI = toView . CRNetworkStatuses (Just user) . map (uncurry ConnNetworkStatus) - statuses = M.foldrWithKey' addStatus [] cts + statuses = M.foldrWithKey' addStatus [] cts where addStatus :: ConnId -> Contact -> [(AgentConnId, NetworkStatus)] -> [(AgentConnId, NetworkStatus)] addStatus _ Contact {activeConn = Nothing} nss = nss addStatus connId Contact {activeConn = Just Connection {agentConnId}} nss = let ns = (agentConnId, netStatus $ resultErr connId rs) - in ns : nss + in ns : nss netStatus :: Maybe ChatError -> NetworkStatus netStatus = maybe NSConnected $ NSError . errorNetworkStatus errorNetworkStatus :: ChatError -> String @@ -2872,7 +2879,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do ChatErrorAgent (BROKER _ NETWORK) _ -> "network" ChatErrorAgent (SMP SMP.AUTH) _ -> "contact deleted" e -> show e --- TODO possibly below could be replaced with less noisy events for API + -- TODO possibly below could be replaced with less noisy events for API contactLinkSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId UserContact -> m () contactLinkSubsToView rs = toView . CRUserContactSubSummary user . map (uncurry UserContactSubStatus) . resultsFor rs groupSubsToView :: Map ConnId (Either AgentErrorType ()) -> [Group] -> Map ConnId GroupMember -> Bool -> m () @@ -3663,15 +3670,16 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do forM_ (forwardedGroupMsg chatMsg) $ \chatMsg' -> do ChatConfig {highlyAvailable} <- asks config -- members introduced to this invited member - introducedMembers <- if memberCategory m == GCInviteeMember - then withStore' $ \db -> getForwardIntroducedMembers db user m highlyAvailable - else pure [] + introducedMembers <- + if memberCategory m == GCInviteeMember + then withStore' $ \db -> getForwardIntroducedMembers db user m highlyAvailable + else pure [] -- invited members to which this member was introduced invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db user m highlyAvailable let ms = introducedMembers <> invitedMembers msg = XGrpMsgForward (memberId (m :: GroupMember)) chatMsg' brokerTs - unless (null ms) $ - void $ sendGroupMessage user gInfo ms msg + unless (null ms) . void $ + sendGroupMessage user gInfo ms msg RCVD msgMeta msgRcpt -> withAckMessage' agentConnId conn msgMeta $ groupMsgReceived gInfo m conn msgMeta msgRcpt @@ -4041,9 +4049,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do -- sendProbe -> sendProbeHashes (currently) -- sendProbeHashes -> sendProbe (reversed - change order in code, may add delay) sendProbe probe - cs <- if doProbeContacts - then map COMContact <$> withStore' (\db -> getMatchingContacts db user ct) - else pure [] + cs <- + if doProbeContacts + then map COMContact <$> withStore' (\db -> getMatchingContacts db user ct) + else pure [] ms <- map COMGroupMember <$> withStore' (\db -> getMatchingMembers db user ct) sendProbeHashes (cs <> ms) probe probeId else sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32) @@ -4700,8 +4709,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do when (contactMerge && not (contactOrMemberIncognito cgm1)) $ do cgm2Probe_ <- withStore' $ \db -> matchReceivedProbeHash db user cgm1 probeHash forM_ cgm2Probe_ $ \(cgm2, probe) -> - unless (contactOrMemberIncognito cgm2) $ - void $ probeMatch cgm1 cgm2 probe + unless (contactOrMemberIncognito cgm2) . void $ + probeMatch cgm1 cgm2 probe probeMatch :: ContactOrMember -> ContactOrMember -> Probe -> m (Maybe ContactOrMember) probeMatch cgm1 cgm2 probe = @@ -4983,7 +4992,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do Right reMember -> do GroupMemberIntro {introId} <- withStore $ \db -> saveIntroInvitation db reMember m introInv void . sendGroupMessage' user [reMember] (XGrpMemFwd (memberInfo m) introInv) groupId (Just introId) $ - withStore' $ \db -> updateIntroStatus db introId GMIntroInvForwarded + withStore' $ + \db -> updateIntroStatus db introId GMIntroInvForwarded _ -> messageError "x.grp.mem.inv can be only sent by invitee member" xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m () @@ -5037,9 +5047,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do (GCInviteeMember, GCInviteeMember) -> withStore' (\db -> runExceptT $ getIntroduction db refMember sendingMember) >>= \case Right intro -> inviteeXGrpMemCon intro - Left _ -> withStore' (\db -> runExceptT $ getIntroduction db sendingMember refMember) >>= \case - Right intro -> forwardMemberXGrpMemCon intro - Left _ -> messageWarning "x.grp.mem.con: no introduction" + Left _ -> + withStore' (\db -> runExceptT $ getIntroduction db sendingMember refMember) >>= \case + Right intro -> forwardMemberXGrpMemCon intro + Left _ -> messageWarning "x.grp.mem.con: no introduction" (GCInviteeMember, _) -> withStore' (\db -> runExceptT $ getIntroduction db refMember sendingMember) >>= \case Right intro -> inviteeXGrpMemCon intro @@ -5371,7 +5382,7 @@ appendFileChunk ft@RcvFileTransfer {fileId, fileInvitation, fileStatus, cryptoAr append_ filePath = do fsFilePath <- toFSFilePath filePath h <- getFileHandle fileId fsFilePath rcvFiles AppendMode - liftIO (B.hPut h chunk >> hFlush h) `catchThrow` (fileErr . show) + liftIO (B.hPut h chunk >> hFlush h) `catchThrow` (fileErr . show) withStore' $ \db -> updatedRcvFileChunkStored db ft chunkNo when final $ do closeFileHandle fileId rcvFiles @@ -5602,14 +5613,15 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta newMsg = NewMessage {chatMsgEvent, msgBody} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} amId = Just $ groupMemberId' am' - msg <- withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery amId) - `catchChatError` \e -> case e of - ChatErrorStore (SEDuplicateGroupMessage _ _ _ (Just forwardedByGroupMemberId)) -> do - fm <- withStore $ \db -> getGroupMember db user groupId forwardedByGroupMemberId - forM_ (memberConn fm) $ \fmConn -> - void $ sendDirectMessage fmConn (XGrpMemCon $ memberId (am' :: GroupMember)) (GroupId groupId) - throwError e - _ -> throwError e + msg <- + withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery amId) + `catchChatError` \e -> case e of + ChatErrorStore (SEDuplicateGroupMessage _ _ _ (Just forwardedByGroupMemberId)) -> do + fm <- withStore $ \db -> getGroupMember db user groupId forwardedByGroupMemberId + forM_ (memberConn fm) $ \fmConn -> + void $ sendDirectMessage fmConn (XGrpMemCon $ memberId (am' :: GroupMember)) (GroupId groupId) + throwError e + _ -> throwError e pure (am', conn', msg) saveGroupFwdRcvMsg :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> m RcvMessage @@ -5878,10 +5890,10 @@ getCreateActiveUser st testView = do displayName <- getWithPrompt "display name" let validName = mkValidName displayName if - | null displayName -> putStrLn "display name can't be empty" >> getContactName - | null validName -> putStrLn "display name is invalid, please choose another" >> getContactName - | displayName /= validName -> putStrLn ("display name is invalid, you could use this one: " <> validName) >> getContactName - | otherwise -> pure $ T.pack displayName + | null displayName -> putStrLn "display name can't be empty" >> getContactName + | null validName -> putStrLn "display name is invalid, please choose another" >> getContactName + | displayName /= validName -> putStrLn ("display name is invalid, you could use this one: " <> validName) >> getContactName + | otherwise -> pure $ T.pack displayName getWithPrompt :: String -> IO String getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine @@ -6322,13 +6334,14 @@ adminContactReq = either error id $ strDecode "simplex:/contact#/?v=1&smp=smp%3A%2F%2FPQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo%3D%40smp6.simplex.im%2FK1rslx-m5bpXVIdMZg9NLUZ_8JBm8xTt%23MCowBQYDK2VuAyEALDeVe-sG8mRY22LsXlPgiwTNs9dbiLrNuA7f3ZMAJ2w%3D" simplexContactProfile :: Profile -simplexContactProfile = Profile { - displayName = "SimpleX Chat team", - fullName = "", - image = Just (ImageData "data:image/jpg;base64,/9j/4AAQSkZJRgABAgAAAQABAAD/2wBDAAUDBAQEAwUEBAQFBQUGBwwIBwcHBw8KCwkMEQ8SEhEPERATFhwXExQaFRARGCEYGhwdHx8fExciJCIeJBweHx7/2wBDAQUFBQcGBw4ICA4eFBEUHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh7/wAARCAETARMDASIAAhEBAxEB/8QAHwAAAQUBAQEBAQEAAAAAAAAAAAECAwQFBgcICQoL/8QAtRAAAgEDAwIEAwUFBAQAAAF9AQIDAAQRBRIhMUEGE1FhByJxFDKBkaEII0KxwRVS0fAkM2JyggkKFhcYGRolJicoKSo0NTY3ODk6Q0RFRkdISUpTVFVWV1hZWmNkZWZnaGlqc3R1dnd4eXqDhIWGh4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uHi4+Tl5ufo6erx8vP09fb3+Pn6/8QAHwEAAwEBAQEBAQEBAQAAAAAAAAECAwQFBgcICQoL/8QAtREAAgECBAQDBAcFBAQAAQJ3AAECAxEEBSExBhJBUQdhcRMiMoEIFEKRobHBCSMzUvAVYnLRChYkNOEl8RcYGRomJygpKjU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6goOEhYaHiImKkpOUlZaXmJmaoqOkpaanqKmqsrO0tba3uLm6wsPExcbHyMnK0tPU1dbX2Nna4uPk5ebn6Onq8vP09fb3+Pn6/9oADAMBAAIRAxEAPwD7LooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiivP/iF4yFvv0rSpAZek0yn7v+yPeunC4WpiqihBf8A8rOc5w2UYZ4jEPTourfZDvH3jL7MW03SpR53SWUfw+w96veA/F0erRLY3zKl6owD2k/8Ar15EWLEljknqadDK8MqyxMUdTlWB5Br66WS0Hh/ZLfv1ufiNLj7Mo5m8ZJ3g9OTpy+Xn5/pofRdFcd4B8XR6tEthfMEvVHyk9JB/jXY18fiMPUw9R06i1P3PK80w2aYaOIw8rxf3p9n5hRRRWB6AUUVDe3UFlavc3MixxIMsxppNuyJnOMIuUnZIL26gsrV7m5kWOJBlmNeU+I/Gd9e6sk1hI8FvA2Y1z973NVPGnimfXLoxRFo7JD8if3vc1zefevr8syiNKPtKyvJ9Ox+F8Ycb1cdU+rYCTjTi/iWjk1+nbue3eEPEdtrtoMER3SD95Hn9R7Vu18+6bf3On3kd1aSmOVDkEd/Y17J4P8SW2vWY6R3aD97F/Ue1eVmmVPDP2lP4fyPtODeMoZrBYXFO1Zf+Tf8AB7r5o3qKKK8Q/QgooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAqavbTXmmz20Fw1vJIhVZB1FeDa3p15pWoSWl6hWQHr2YeoNfQlY3izw9Z6/YGGZQky8xSgcqf8K9jKcyWEnyzXuv8D4njLhZ51RVSi7VYLRdGu3k+z+88HzRuq1rWmXmkX8lnexFHU8Hsw9RVLNfcxlGcVKLumfgFahUozdOorSWjT6E0M0kMqyxOyOpyrKcEGvXPAPjCPVolsb9wl6owGPAkH+NeO5p8M0kMqyxOyOpyrA4INcWPy+njKfLLfoz2+HuIMTkmI9pT1i/ij0a/wA+zPpGiuM+H/jCPV4lsL91S+QfKTwJR/jXW3t1BZWslzcyLHFGMsxNfB4jC1aFX2U1r+fof0Rl2bYXMMKsVRl7vXy7p9rBfXVvZWr3NzKscSDLMTXjnjbxVPrtyYoiY7JD8if3vc0zxv4ruNeujFEWjsoz8if3vc1zOa+synKFh0qtVe9+X/BPxvjLjKWZSeEwjtSW7/m/4H5kmaM1HmlB54r3bH51YkzXo3wz8MXMc0es3ZeED/VR5wW9z7VB8O/BpnMerarEREDuhhb+L3Pt7V6cAAAAAAOgFfL5xmqs6FH5v9D9a4H4MlzQzHGq1tYR/KT/AEXzCiiivlj9hCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxfFvh208QWBhmASdRmKUdVP+FeH63pl5pGoSWV5EUdTwezD1HtX0VWL4t8O2fiHTzBONk6g+TKByp/wr28pzZ4WXs6msH+B8NxdwhTzeDxGHVqy/8m8n59n954FmjNW9b0y80fUHsr2MpIp4PZh6iqWfevuYyjOKlF3TPwetQnRm6dRWktGmSwzSQyrLE7I6nKsDgg1teIPFOqa3a29vdy4jiUAheN7f3jWBmjNROhTnJTkrtbGtLF4ijSnRpzajPddHbuP3e9Lmo80ua0scth+a9E+HXgw3Hl6tqsZEX3oYmH3vc+1J8OPBZnKavq0eIhzDCw+9/tH29q9SAAAAGAOgr5bOM35b0KD16v8ARH6twXwXz8uPx0dN4xfXzf6IFAUAAAAdBRRRXyZ+wBRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFB4GTXyj+1p+0ONJjufA3ga6DX7qU1DUY24gB4McZH8Xqe38tqFCdefLETaSufQ3h/4geEde8Uah4a0rWra51Ow/wBfCrD8ceuO+OldRX5I+GfEWseG/ENvr2j30ttqFvJ5iSqxyT3z6g96/RH9nD41aT8U9AWGcx2fiK1QC7tC33/+mieqn07V14zL3QXNHVEQnc9dooorzjQKKKKACiis7xHrel+HdGudY1m8is7K2QvLLI2AAP600m3ZAYfxUg8Pr4VutT1+7isYbSMuLp/4Pb3z6V8++HNd0zxDpq6hpVys8DHGRwVPoR2NeIftJ/G7VPifrbWVk8lp4btZD9mtwcGU/wDPR/c9h2rgfh34z1LwdrAurV2ktZCBcW5PyyD/AB9DX2WTyqYWny1Ho+nY+C4t4Wp5tF16CtVX/k3k/Ps/vPr/ADRmsjwx4g07xFpMWpaZOJInHI/iQ9wR61qbq+mVmro/D6tCdGbp1FZrdEma6/4XafpWoa7jUpV3oA0MLdJD/ntXG5p8E0kMqyxOyOhyrKcEGsMTRlWpShGVm+p1ZbiYYPFQr1IKai72fU+nFAUAKAAOABRXEfDnxpFrMK6fqDhL9BhSeko9frXb1+a4rDVMNUdOotT+k8szLD5lh44jDu8X968n5hRRRXOegFFFFABUGoXlvYWkl1dSrHFGMliaL+7t7C0kuruVYoYxlmNeI+OvFtx4huzHFuisYz+7jz97/aNenluW1MbU00it2fM8S8SUMkoXetR/DH9X5fmeteF/E+m+IFkFoxSWMnMb9cev0rbr5t0vULrTb6K8s5TFNGcgj+R9q9w8E+KbXxDYjlY7xB+9i/qPaurNsneE/eUtYfkeTwlxjHNV9XxVo1V90vTz8vmjoqKKK8I+8CiiigAooooAKKKKACiiigD5V/a8+P0mgvdeAvCUskepFdl9eDjyQR9xPfHeviiR3lkaSR2d2OWZjkk+tfoj+058CtP+Jektq2jxRWnie2T91KMKLlR/yzf+h7V+fOuaVqGiarcaXqtpLaXls5jlikXDKRX0mWSpOlaG/U56l76lKtPwtr+reGNetdb0S8ls761cPHJG2D9D6g9MVmUV6TSasyD9Jf2cfjXpPxR0MW9w0dp4gtkAubYnHmf7aeo/lXr1fkh4W1/V/DGuW2taHey2d9bOHjkjP6H1HtX6Jfs5fGvR/inoQgmeOz8RWqD7XaE439vMT1U+navnMfgHRfPD4fyN4Tvoz12iis7xJremeHdEutZ1i7jtLK1jLyyucAAf1rzUm3ZGgeJNb0vw7otzrOs3kVpZWyF5ZZDgAD+Z9q/PL9pP436r8UNZaxs2ks/Dlq5+z24ODMf77+p9B2o/aU+N2p/FDXDZ2LS2fhy1ci3t84Mx/wCej+/oO1eNV9DgMAqS55/F+RhOd9EFFFABJwBkmvUMzqPh34y1Lwjq63FszSWshAntyeHHt719Z2EstzpVlqD2txbR3kCzxLPGUbawyODXK/slfs8nUpbXx144tGFkhElhp8q4849pHB/h9B3r608X+GLDxBpX2WRFiljX9xIowUPYfT2rGnnkMPWVJ6x6vt/XU+P4o4SjmtN4igrVV/5N5Pz7P7z56zRmrmvaVe6LqMljexMkiHg9mHqKoZr6uEozipRd0z8Rq0J0ZunUVmtGmTwTSQTJNC7JIhyrKcEGvZvhz41j1mJdP1GRUv0GFY8CX/69eJZqSCaWCVZYXZHU5VlOCDXDmGXU8bT5ZaPo+x7WQZ9iMlxHtKesX8UejX+fZn1FRXDfDbxtHrUKadqDqmoIuAx4EoHf613NfnWKwtTC1HTqKzR/QGW5lh8yw8cRh3eL+9Ps/MKr6heW1hZyXd3KsUUYyzGjUby20+zku7yZYoY13MzGvDPHvi+48RXpjiZorCM/u4/73+0feuvLMsqY6pZaRW7/AK6nlcScR0MloXetR/DH9X5D/Hni648Q3nlxlo7GM/u48/e9zXL7qZmjNfodDDwoU1TpqyR+AY7G18dXlXryvJ/19w/dVvSdRutMvo7yzlaOVDkY7+xqkDmvTPhn4HMxj1jV4v3Y+aCFh97/AGjWGPxNHDUXKrt27+R15JlWLzHFxp4XSS1v/L53PQ/C+oXGqaJb3t1bNbyyLkoe/v8AQ1p0AAAAAADoBRX5nUkpSbirLsf0lh6c6dKMJy5mkrvv5hRRRUGwUUUUAFFFFABRRRQAV4d+038CdO+JWkyavo8cdp4mtkzHIBhbkD+B/f0Ne40VpSqypSUovUTV9GfkTruk6joer3Ok6taS2d7ayGOaGVdrKRVKv0T/AGnfgXp/xK0h9Y0iOO18TWqZikAwLkD+B/6Gvz51zStQ0TVbjS9UtZbW8tnKSxSLgqRX1GExccRG636o55RcSlWp4V1/VvDGvWut6JeSWl9bOGjkQ4/A+oPpWXRXU0mrMk/RP4LftDeFvF3ge41HxDfW+lappkG+/idsBwP40HfJ7V8o/tJ/G/VPifrbWVk8tn4btn/0e2zgykfxv6n0HavGwSM4JGeuO9JXFRwFKlUc18vIpzbVgoooAJIAGSa7SQr6x/ZM/Z4k1J7Xxz44tClkMSWFhIuDL3Ejg/w+g70fsmfs8NqMtt448c2eLJCJLCwlX/WnqHcH+H0HevtFFVECIoVVGAAMACvFx+PtenTfqzWEOrEjRI41jjUIigBVAwAPSnUUV4ZsYXjLwzZeJNOaCcBLhQfJmA5U/wCFeBa/pV7ompSWF9GUkToccMOxHtX01WF4z8M2XiXTTBOAk6AmGYDlD/hXvZPnEsHL2dTWD/A+K4r4UhmsHXoK1Zf+TeT8+z+8+c80Zq5r2k3ui6jJY30ZSRTwezD1FUM1+gQlGcVKLumfiFWjOjN06is1umTwTSQTJNE7JIh3KynBBr2PwL8QrO701odbnSC5t0yZCcCUD+teK5pd1cWPy2ljoctTdbPqetkme4rJ6rqUHdPdPZ/8Mdb4/wDGFz4ivDFGxisIz+7j/ve5rls1HuozXTQw1PD01TpqyR5+OxlfHV5V68ryf9fcSZozTAa9P+GHgQzmPWdZhIjHzQQMPvf7R9qxxuMpYOk6lR/8E6MpyfEZriFQoL1fRLux/wAMvApmMesazFiP70EDfxf7R9vavWFAUAAAAcACgAAAAAAdBRX5xjsdVxtXnn8l2P3/ACXJcNlGHVGivV9W/wCugUUUVxHrhRRRQAUUUUAFFFFABRRRQAUUUUAFeH/tOfArT/iXpUmsaSsVp4mto/3UuMLcgDhH/oe1e4Vn+I9a0zw7otzrGsXkVpZWyF5ZZGwAB/WtaNSdOalDcTSa1PyZ1zStQ0TVrnStVtZLS8tnMcsUgwVIqlXp/wC0l8S7T4nePn1aw0q3srO3XyYJBGBNOoPDSHv7DtXmFfXU5SlBOSszlYUUUVYAAScDk19Zfsmfs7vqLW3jjx1ZFLMESafYSjmXuJHHZfQd6+VtLvJtO1K2v7cRtLbyrKgkQOpKnIyp4I46Gv0b/Zv+NOjfFDw+lrIIrDX7RAtzZ8AMMffj9V9u1efmVSrCn7m3Vl00m9T16NEjjWONVRFGFUDAA9KWiivmToCiiigAooooAwfGnhiy8S6cYJwEuEH7mYDlT/hXz7r+k32h6lJYahFskQ8Hsw9QfSvpjUr2106ykvLyZYYYxlmY18+/EXxa/ijU1aOMRWkGRCCBuPuT/Svr+GK2KcnTSvT/ACfl/kfmPiBhMvUI1m7Vn0XVefp0fy9Oa3UbqZmjNfa2PynlJM+9AOajzTo5GjkV0YqynIPoaVg5T1P4XeA/P8vWdaiIj+9BAw+9/tH29q9dAAAAAAHQVwPwx8dQ63Ammai6R6hGuFJ4Ew9vf2rvq/Ms5qYmeJaxGjWy6W8j+gOFcPl9LAReBd0931b8+3oFFFFeSfSBRRRQAUUUUAFFFFABRRRQAUUUUAFFFZ3iTW9L8OaJdazrN5HaWNqheWWQ4AH+NNJt2QB4l1vTPDmiXWs6xdx2llaxl5ZHOAAO3ufavzx/aT+N2qfFDWzZWbSWfhy2ci3tg2DKf77+p9B2pf2lfjdqfxQ1trGxeW08N2z/AOj2+cGYj/lo/v6DtXjVfQ4DAKkuefxfkYTnfRBRRQAScAZNeoZhRXv3w2/Zh8V+Lfh7deJprgadcvHv02zlT5rgdcsf4Qe1eHa5pWoaJq1zpWq2ktpeW0hjlikXDKwrOFanUk4xd2htNFKtTwrr+reGNdtta0S8ltL22cPHIhx07H1HtWXRWjSasxH6S/s4/GrSfijoYtp3jtfENqg+1WpON4/vp6j27V69X5IeFfEGr+F9etdc0O9ks7+1cPHKh/QjuD3Ffoj+zl8bNI+KWhLbztFZ+IraMfa7TON+Osieqn07V85j8A6L54fD+RvCd9GevUUUV5hoFVtTvrXTbGW9vJligiXczNRqd9aabYy3t7MsMEQyzMa+ffiN42uvE96YoS0OmxH91F3b/ab3r1spympmFSy0it3+i8z57iDiCjlFG71qPZfq/Id8RPGl14lvTFEzRafGf3cf97/aNclmmZozX6Xh8NTw1NU6askfheNxdbG1pV68ryY/NGTTM16R4J+GVxrGkSX+pSSWfmJ/oq45J7MR6Vni8ZRwkOes7I1y7K8TmNX2WHjd7/0zzvJozV3xDpF7oepyWF/EUkQ8HHDD1FZ+feuiEozipRd0zjq0Z0puE1ZrdE0E8sEyTQu0ciHKspwQa9z+GHjuLXIU0zUpFTUEXCseBKB/WvBs1JBPLBMk0LmORCGVlOCDXn5lllLH0uWWjWz7HsZFnlfJ6/tKesXuu6/z7M+tKK4D4X+PItdhTTNSdY9SQYVicCYDuPf2rv6/M8XhKuEqulVVmj92y7MaGYUFXoO6f4Ps/MKKKK5juCiiigAooooAKKKKACiig9KAM7xLrmleG9EudZ1q8jtLG2QvLK5wAPQep9q/PH9pP43ap8T9beyspJbTw3bSH7NbZx5pH8b+p9u1bH7YPxL8XeJPG114V1G0udH0jT5SIrNuDOR0kbs2e3pXgdfRZfgVTSqT3/IwnO+iCiigAkgAZJr1DMK+s/2TP2d31Brbxz46tNtmMSafp8i8y9/MkB6L0wO9J+yb+zwdSe28b+ObLFmpEljYSr/rT1DuP7voO9faCKqIERQqqMAAYAFeLj8fa9Om/VmsIdWEaJGixooVFGFUDAA9K8Q/ac+BWnfErSZNY0mOO08T2yZilAwtyAPuP/Q9q9worx6VWVKSlF6mrSasfkTrmlahomrXOlaray2l7bSGOaKRcMrCqVfon+098C7D4l6U+s6Skdr4mtY/3UmMC5UdI29/Q1+fOt6XqGi6rcaVqlrJa3ls5SWKQYKkV9RhMXHERut+qOeUeUpVqeFfEGreGNdttb0W7ktb22cNG6HH4H1FZdFdTSasyT9Jf2cPjVpXxR0Fbe4eK18Q2qD7Va7sbx/z0T1H8q9V1O+tdNsZb29mWGCJdzMxr8ovAOoeIdK8W2GoeF5podVhlDQtEefcH2PevsbxP4417xTp1jDq3lQGKFPOigJ2NLj5m59849K4KHD0sTX9x2h18vJHj55xDSyqhd61Hsv1fkaXxG8bXXie9MURaLTo2/dR5+9/tH3rkM1HmjNffYfC08NTVOmrJH4ljMXWxtaVau7yZJmgHmmAmvWfhN8PTceVrmuQkRDDW9uw+9/tN7Vjj8dSwNJ1ar9F3OjK8pr5nXVGivV9Eu7H/Cf4emcx63rkJEfDW9u4+9/tMPT2r2RQFAVQABwAKAAAAAAB0Aor8uzDMKuOq+0qfJdj9zyjKMPlVBUaK9X1bOf8b+FbHxRppt7gCO4UfuZwOUP9R7V86+IdHv8AQtTk0/UIikqHg9mHqD6V9VVz3jnwrY+KNMNvcKEuEBME2OUP+FenkmdywUvZVdab/A8PijheGZw9vQVqq/8AJvJ+fZnzLuo3Ve8Q6Pf6FqclhqERjkQ8Hsw9Qazs1+jwlGpFSi7pn4xVozpTcJqzW6J7eeSCZJoZGjkQhlZTgg17t8LvHsWuQppmpOseooMKxPEw/wAa8DzV3Q7fULvVIIdLWQ3ZcGMx8EH1z2rzs1y2jjaLVTRrZ9v+AezkGcYnK8SpUVzKWjj3/wCD2PrCiqOgx38Oj20eqTJNeLGBK6jAJq9X5VOPLJq9z98pyc4KTVr9H0CiiipLCiiigAooooAKKKKAPK/2hfg3o/xT8PFdsVprlupNnebec/3W9VNfnR4y8Naz4R8RXWg69ZvaXts5V1YcEdmB7g9jX6115V+0P8GtF+Knh05SO0161UmzvQuD/uP6qf0r08DjnRfJP4fyM5wvqj80RycCvrP9kz9ndtRNr458dWTLaAiTT9PlXBl9JJB/d7gd+tXv2bv2Y7yz19vEHxFs1VbKYi1sCQwlZTw7f7PcDvX2CiLGioihVUYAAwAK6cfmGns6T9WTCHVhGiRoqRqFRRgKBgAUtFFeGbBRRRQAV4h+038CtP8AiZpTatpCQ2fia2jPlS4wtyo52P8A0Pavb6K0pVZUpKUXqJq+jPyJ1zStQ0TVrnStVtJbS9tnMcsUgwVIqPS7C61O+isrKFpZ5W2qor9AP2r/AIM6J448OzeJLV7fTtesoyRO3yrcqP4H9/Q14F8OvBlp4XsvMkCTajKP3suM7f8AZX0H86+1yiDzFcy0S3Pms+zqllNLXWb2X6vyH/DnwZaeF7EPIEm1CUDzZcfd/wBke1dfmo80ua+0pUY0oqMVofjWLxNXF1XWrO8mSZozUea9N+B/hTTdau5NUv5opvsrjbak8k9mYelc+OxcMHQlWqbI1y3LqmYYmOHpbvuafwj+HhnMWva5DiMENb27D73ozD09q9oAAAAAAHQCkUBVCqAAOABS1+U5jmNXH1XUqfJdj9yyjKKGV0FRor1fVsKKKK4D1AooooA57xz4UsPFOmG3uFEdwgJgnA5Q/wBR7V84eI9Gv9A1SXT9RhMcqHg/wuOxB7ivrCud8d+E7DxTpZt51CXKDMEwHKn/AAr6LI88lgpeyq603+Hmv1Pj+J+GIZnB16KtVX/k3k/Psz5p0uxu9Tv4rGxheaeVtqIoyTX0T8OPBNp4XsRJKFm1GQfvZf7v+yvtR8OfBFn4UtDIxW41CUfvJsdB/dX0FdfWue568W3RoP3Pz/4BhwvwtHL0sTiVeq9l/L/wQooor5g+3CiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKrarf2ml2E19fTpBbwrud2OAKTVdQtNLsJb6+mWGCJcszGvm34nePLzxXfmGEtDpkTfuos/f/wBpvevZyfJ6uZVbLSC3f6LzPBz3PaOVUbvWb2X6vyH/ABM8d3fiq/MULPDpsR/dRdN3+03vXF5pm6jdX6phsLTw1JUqSskfjGLxVbGVnWrO8mSZ96M0wGnSq8UhjkRkdeCrDBFb2OXlFzWn4b1y/wBA1SPUNPmMciHkdmHoR6Vk7hS596ipTjUi4zV0y6c50pqcHZrZn1X4C8W2HizShc27BLmMATwZ5Q/4V0dfIfhvXL/w/qseo6dMY5U6js47gj0r6Y8BeLtP8WaUtzbER3KAefATyh/qPevzPPshlgJe1pa03+Hk/wBGfr/DfEkcygqNbSqv/JvNefdHSUUUV80fWhRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFVtVv7TS7CW+vp1ht4l3O7HpSatqNnpWny319OsMES7mZjXzP8UfH154tv8AyYWeDS4WPlQ5xvP95vU/yr2smyarmVWy0gt3+i8zws8zylldK71m9l+r8h/xP8eXfiy/MUJaHTIm/cxZ5b/ab3ris0zNGa/V8NhaWFpKlSVkj8bxeKrYuq61Z3kx+aX2pmTXsnwc+GrXBh8Qa/CViB3W9sw5b0Zh6e1YZhj6OAourVfourfY3y3LK+Y11Ror1fRLux3wc+GxuPK1/X4SIgQ1tbuPvf7TD09BXT/Fv4dQ6/bPqukxpFqca5KgYE4Hb6+9ekKAqhVAAHAApa/L62fYupi1ilKzWy6W7f5n63R4bwVPBPBuN0931v3/AMj4wuIZred4J42jlQlWVhgg0zNfRHxc+HUXiCB9W0mNI9TRcso4EwH9a+eLiKW2neCeNo5UO1kYYIPpX6TlOa0cypc8NJLddv8AgH5XnOS1srrck9YvZ9/+CJmtPw1rl/4f1WLUdPmMcqHkZ4Yeh9qys0Zr0qlONSLhNXTPKpznSmpwdmtmfWHgDxfp/i3SVubZhHcoAJ4CfmQ/1HvXSV8feGdd1Dw9q0WpabMY5UPIz8rr3UjuK+nPAHjDT/FulLcW7CO6QYngJ5Q/1FfmGfZBLAS9rS1pv8PJ/oz9c4c4jjmMFRraVV/5N5rz7o6WiiivmT6wKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAOY+JXhRfFvh5rAXDwTod8LA/KW9GHcV8s65pV/oupzadqNu0FxC2GVu/uPUV9m1x/xM8DWHi/TD8qw6jEP3E4HP+6fUV9Tw7n7wEvY1v4b/AAf+Xc+S4k4eWYR9vR/iL8V29ex8q5o+gq9ruk32i6nLp2oQNFPG2CCOvuPUV6v8Gvhk1w0PiDxDBiH71tbOPvejMPT2r9Cx2Z4fB4f283o9rdfQ/OMBlWIxuI+rwjZre/T1F+DPw0NwYfEPiCDEQ+a2tnH3vRmHp6Cvc1AVQqgADgAUKoVQqgAAYAHalr8lzPMq2Y1nVqv0XRI/YsryuhltBUqS9X1bCiiivOPSCvNfi98OYvEVu+raTEseqRrllHAnHoff3r0qiuvBY2tgqyq0nZr8fJnHjsDRx1F0ayun+Hmj4ruIZbad4J42ilQlWRhgg1Hmvoz4vfDiLxDA+raRGseqRjLIOBOP8a8AsdI1K91hdIgtJDetJ5ZiK4Knvn0xX6zleb0Mwoe1Ts1uu3/A8z8dzbJK+XYj2TV0/hff/g+Q3SbC81XUIbCwgee4mYKiKOpr6a+F3ga28IaaWkYTajOo8+Tsv+yvtTPhd4DtPCWnCWULNqcq/vZcfd/2V9q7avh+IeIHjG6FB/u1u+//AAD73hrhuOBSxGIV6j2X8v8AwQooor5M+xCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxdd8LaHrd/a32pWKTT2rbo2Pf2PqK2VAVQqgAAYAHalorSVWc4qMm2lt5GcKNOEnKMUm9/MKKKKzNAooooAKKKKACs+HRdLh1iXV4rKFb6VQrzBfmIrQoqozlG/K7XJlCMrOSvYKKKKkoKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooA//2Q=="), - contactLink = Just adminContactReq, - preferences = Nothing -} +simplexContactProfile = + Profile + { displayName = "SimpleX Chat team", + fullName = "", + image = Just (ImageData "data:image/jpg;base64,/9j/4AAQSkZJRgABAgAAAQABAAD/2wBDAAUDBAQEAwUEBAQFBQUGBwwIBwcHBw8KCwkMEQ8SEhEPERATFhwXExQaFRARGCEYGhwdHx8fExciJCIeJBweHx7/2wBDAQUFBQcGBw4ICA4eFBEUHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh7/wAARCAETARMDASIAAhEBAxEB/8QAHwAAAQUBAQEBAQEAAAAAAAAAAAECAwQFBgcICQoL/8QAtRAAAgEDAwIEAwUFBAQAAAF9AQIDAAQRBRIhMUEGE1FhByJxFDKBkaEII0KxwRVS0fAkM2JyggkKFhcYGRolJicoKSo0NTY3ODk6Q0RFRkdISUpTVFVWV1hZWmNkZWZnaGlqc3R1dnd4eXqDhIWGh4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uHi4+Tl5ufo6erx8vP09fb3+Pn6/8QAHwEAAwEBAQEBAQEBAQAAAAAAAAECAwQFBgcICQoL/8QAtREAAgECBAQDBAcFBAQAAQJ3AAECAxEEBSExBhJBUQdhcRMiMoEIFEKRobHBCSMzUvAVYnLRChYkNOEl8RcYGRomJygpKjU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6goOEhYaHiImKkpOUlZaXmJmaoqOkpaanqKmqsrO0tba3uLm6wsPExcbHyMnK0tPU1dbX2Nna4uPk5ebn6Onq8vP09fb3+Pn6/9oADAMBAAIRAxEAPwD7LooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiivP/iF4yFvv0rSpAZek0yn7v+yPeunC4WpiqihBf8A8rOc5w2UYZ4jEPTourfZDvH3jL7MW03SpR53SWUfw+w96veA/F0erRLY3zKl6owD2k/8Ar15EWLEljknqadDK8MqyxMUdTlWB5Br66WS0Hh/ZLfv1ufiNLj7Mo5m8ZJ3g9OTpy+Xn5/pofRdFcd4B8XR6tEthfMEvVHyk9JB/jXY18fiMPUw9R06i1P3PK80w2aYaOIw8rxf3p9n5hRRRWB6AUUVDe3UFlavc3MixxIMsxppNuyJnOMIuUnZIL26gsrV7m5kWOJBlmNeU+I/Gd9e6sk1hI8FvA2Y1z973NVPGnimfXLoxRFo7JD8if3vc1zefevr8syiNKPtKyvJ9Ox+F8Ycb1cdU+rYCTjTi/iWjk1+nbue3eEPEdtrtoMER3SD95Hn9R7Vu18+6bf3On3kd1aSmOVDkEd/Y17J4P8SW2vWY6R3aD97F/Ue1eVmmVPDP2lP4fyPtODeMoZrBYXFO1Zf+Tf8AB7r5o3qKKK8Q/QgooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAqavbTXmmz20Fw1vJIhVZB1FeDa3p15pWoSWl6hWQHr2YeoNfQlY3izw9Z6/YGGZQky8xSgcqf8K9jKcyWEnyzXuv8D4njLhZ51RVSi7VYLRdGu3k+z+88HzRuq1rWmXmkX8lnexFHU8Hsw9RVLNfcxlGcVKLumfgFahUozdOorSWjT6E0M0kMqyxOyOpyrKcEGvXPAPjCPVolsb9wl6owGPAkH+NeO5p8M0kMqyxOyOpyrA4INcWPy+njKfLLfoz2+HuIMTkmI9pT1i/ij0a/wA+zPpGiuM+H/jCPV4lsL91S+QfKTwJR/jXW3t1BZWslzcyLHFGMsxNfB4jC1aFX2U1r+fof0Rl2bYXMMKsVRl7vXy7p9rBfXVvZWr3NzKscSDLMTXjnjbxVPrtyYoiY7JD8if3vc0zxv4ruNeujFEWjsoz8if3vc1zOa+synKFh0qtVe9+X/BPxvjLjKWZSeEwjtSW7/m/4H5kmaM1HmlB54r3bH51YkzXo3wz8MXMc0es3ZeED/VR5wW9z7VB8O/BpnMerarEREDuhhb+L3Pt7V6cAAAAAAOgFfL5xmqs6FH5v9D9a4H4MlzQzHGq1tYR/KT/AEXzCiiivlj9hCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxfFvh208QWBhmASdRmKUdVP+FeH63pl5pGoSWV5EUdTwezD1HtX0VWL4t8O2fiHTzBONk6g+TKByp/wr28pzZ4WXs6msH+B8NxdwhTzeDxGHVqy/8m8n59n954FmjNW9b0y80fUHsr2MpIp4PZh6iqWfevuYyjOKlF3TPwetQnRm6dRWktGmSwzSQyrLE7I6nKsDgg1teIPFOqa3a29vdy4jiUAheN7f3jWBmjNROhTnJTkrtbGtLF4ijSnRpzajPddHbuP3e9Lmo80ua0scth+a9E+HXgw3Hl6tqsZEX3oYmH3vc+1J8OPBZnKavq0eIhzDCw+9/tH29q9SAAAAGAOgr5bOM35b0KD16v8ARH6twXwXz8uPx0dN4xfXzf6IFAUAAAAdBRRRXyZ+wBRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFB4GTXyj+1p+0ONJjufA3ga6DX7qU1DUY24gB4McZH8Xqe38tqFCdefLETaSufQ3h/4geEde8Uah4a0rWra51Ow/wBfCrD8ceuO+OldRX5I+GfEWseG/ENvr2j30ttqFvJ5iSqxyT3z6g96/RH9nD41aT8U9AWGcx2fiK1QC7tC33/+mieqn07V14zL3QXNHVEQnc9dooorzjQKKKKACiis7xHrel+HdGudY1m8is7K2QvLLI2AAP600m3ZAYfxUg8Pr4VutT1+7isYbSMuLp/4Pb3z6V8++HNd0zxDpq6hpVys8DHGRwVPoR2NeIftJ/G7VPifrbWVk8lp4btZD9mtwcGU/wDPR/c9h2rgfh34z1LwdrAurV2ktZCBcW5PyyD/AB9DX2WTyqYWny1Ho+nY+C4t4Wp5tF16CtVX/k3k/Ps/vPr/ADRmsjwx4g07xFpMWpaZOJInHI/iQ9wR61qbq+mVmro/D6tCdGbp1FZrdEma6/4XafpWoa7jUpV3oA0MLdJD/ntXG5p8E0kMqyxOyOhyrKcEGsMTRlWpShGVm+p1ZbiYYPFQr1IKai72fU+nFAUAKAAOABRXEfDnxpFrMK6fqDhL9BhSeko9frXb1+a4rDVMNUdOotT+k8szLD5lh44jDu8X968n5hRRRXOegFFFFABUGoXlvYWkl1dSrHFGMliaL+7t7C0kuruVYoYxlmNeI+OvFtx4huzHFuisYz+7jz97/aNenluW1MbU00it2fM8S8SUMkoXetR/DH9X5fmeteF/E+m+IFkFoxSWMnMb9cev0rbr5t0vULrTb6K8s5TFNGcgj+R9q9w8E+KbXxDYjlY7xB+9i/qPaurNsneE/eUtYfkeTwlxjHNV9XxVo1V90vTz8vmjoqKKK8I+8CiiigAooooAKKKKACiiigD5V/a8+P0mgvdeAvCUskepFdl9eDjyQR9xPfHeviiR3lkaSR2d2OWZjkk+tfoj+058CtP+Jektq2jxRWnie2T91KMKLlR/yzf+h7V+fOuaVqGiarcaXqtpLaXls5jlikXDKRX0mWSpOlaG/U56l76lKtPwtr+reGNetdb0S8ls761cPHJG2D9D6g9MVmUV6TSasyD9Jf2cfjXpPxR0MW9w0dp4gtkAubYnHmf7aeo/lXr1fkh4W1/V/DGuW2taHey2d9bOHjkjP6H1HtX6Jfs5fGvR/inoQgmeOz8RWqD7XaE439vMT1U+navnMfgHRfPD4fyN4Tvoz12iis7xJremeHdEutZ1i7jtLK1jLyyucAAf1rzUm3ZGgeJNb0vw7otzrOs3kVpZWyF5ZZDgAD+Z9q/PL9pP436r8UNZaxs2ks/Dlq5+z24ODMf77+p9B2o/aU+N2p/FDXDZ2LS2fhy1ci3t84Mx/wCej+/oO1eNV9DgMAqS55/F+RhOd9EFFFABJwBkmvUMzqPh34y1Lwjq63FszSWshAntyeHHt719Z2EstzpVlqD2txbR3kCzxLPGUbawyODXK/slfs8nUpbXx144tGFkhElhp8q4849pHB/h9B3r608X+GLDxBpX2WRFiljX9xIowUPYfT2rGnnkMPWVJ6x6vt/XU+P4o4SjmtN4igrVV/5N5Pz7P7z56zRmrmvaVe6LqMljexMkiHg9mHqKoZr6uEozipRd0z8Rq0J0ZunUVmtGmTwTSQTJNC7JIhyrKcEGvZvhz41j1mJdP1GRUv0GFY8CX/69eJZqSCaWCVZYXZHU5VlOCDXDmGXU8bT5ZaPo+x7WQZ9iMlxHtKesX8UejX+fZn1FRXDfDbxtHrUKadqDqmoIuAx4EoHf613NfnWKwtTC1HTqKzR/QGW5lh8yw8cRh3eL+9Ps/MKr6heW1hZyXd3KsUUYyzGjUby20+zku7yZYoY13MzGvDPHvi+48RXpjiZorCM/u4/73+0feuvLMsqY6pZaRW7/AK6nlcScR0MloXetR/DH9X5D/Hni648Q3nlxlo7GM/u48/e9zXL7qZmjNfodDDwoU1TpqyR+AY7G18dXlXryvJ/19w/dVvSdRutMvo7yzlaOVDkY7+xqkDmvTPhn4HMxj1jV4v3Y+aCFh97/AGjWGPxNHDUXKrt27+R15JlWLzHFxp4XSS1v/L53PQ/C+oXGqaJb3t1bNbyyLkoe/v8AQ1p0AAAAAADoBRX5nUkpSbirLsf0lh6c6dKMJy5mkrvv5hRRRUGwUUUUAFFFFABRRRQAV4d+038CdO+JWkyavo8cdp4mtkzHIBhbkD+B/f0Ne40VpSqypSUovUTV9GfkTruk6joer3Ok6taS2d7ayGOaGVdrKRVKv0T/AGnfgXp/xK0h9Y0iOO18TWqZikAwLkD+B/6Gvz51zStQ0TVbjS9UtZbW8tnKSxSLgqRX1GExccRG636o55RcSlWp4V1/VvDGvWut6JeSWl9bOGjkQ4/A+oPpWXRXU0mrMk/RP4LftDeFvF3ge41HxDfW+lappkG+/idsBwP40HfJ7V8o/tJ/G/VPifrbWVk8tn4btn/0e2zgykfxv6n0HavGwSM4JGeuO9JXFRwFKlUc18vIpzbVgoooAJIAGSa7SQr6x/ZM/Z4k1J7Xxz44tClkMSWFhIuDL3Ejg/w+g70fsmfs8NqMtt448c2eLJCJLCwlX/WnqHcH+H0HevtFFVECIoVVGAAMACvFx+PtenTfqzWEOrEjRI41jjUIigBVAwAPSnUUV4ZsYXjLwzZeJNOaCcBLhQfJmA5U/wCFeBa/pV7ompSWF9GUkToccMOxHtX01WF4z8M2XiXTTBOAk6AmGYDlD/hXvZPnEsHL2dTWD/A+K4r4UhmsHXoK1Zf+TeT8+z+8+c80Zq5r2k3ui6jJY30ZSRTwezD1FUM1+gQlGcVKLumfiFWjOjN06is1umTwTSQTJNE7JIh3KynBBr2PwL8QrO701odbnSC5t0yZCcCUD+teK5pd1cWPy2ljoctTdbPqetkme4rJ6rqUHdPdPZ/8Mdb4/wDGFz4ivDFGxisIz+7j/ve5rls1HuozXTQw1PD01TpqyR5+OxlfHV5V68ryf9fcSZozTAa9P+GHgQzmPWdZhIjHzQQMPvf7R9qxxuMpYOk6lR/8E6MpyfEZriFQoL1fRLux/wAMvApmMesazFiP70EDfxf7R9vavWFAUAAAAcACgAAAAAAdBRX5xjsdVxtXnn8l2P3/ACXJcNlGHVGivV9W/wCugUUUVxHrhRRRQAUUUUAFFFFABRRRQAUUUUAFeH/tOfArT/iXpUmsaSsVp4mto/3UuMLcgDhH/oe1e4Vn+I9a0zw7otzrGsXkVpZWyF5ZZGwAB/WtaNSdOalDcTSa1PyZ1zStQ0TVrnStVtZLS8tnMcsUgwVIqlXp/wC0l8S7T4nePn1aw0q3srO3XyYJBGBNOoPDSHv7DtXmFfXU5SlBOSszlYUUUVYAAScDk19Zfsmfs7vqLW3jjx1ZFLMESafYSjmXuJHHZfQd6+VtLvJtO1K2v7cRtLbyrKgkQOpKnIyp4I46Gv0b/Zv+NOjfFDw+lrIIrDX7RAtzZ8AMMffj9V9u1efmVSrCn7m3Vl00m9T16NEjjWONVRFGFUDAA9KWiivmToCiiigAooooAwfGnhiy8S6cYJwEuEH7mYDlT/hXz7r+k32h6lJYahFskQ8Hsw9QfSvpjUr2106ykvLyZYYYxlmY18+/EXxa/ijU1aOMRWkGRCCBuPuT/Svr+GK2KcnTSvT/ACfl/kfmPiBhMvUI1m7Vn0XVefp0fy9Oa3UbqZmjNfa2PynlJM+9AOajzTo5GjkV0YqynIPoaVg5T1P4XeA/P8vWdaiIj+9BAw+9/tH29q9dAAAAAAHQVwPwx8dQ63Ammai6R6hGuFJ4Ew9vf2rvq/Ms5qYmeJaxGjWy6W8j+gOFcPl9LAReBd0931b8+3oFFFFeSfSBRRRQAUUUUAFFFFABRRRQAUUUUAFFFZ3iTW9L8OaJdazrN5HaWNqheWWQ4AH+NNJt2QB4l1vTPDmiXWs6xdx2llaxl5ZHOAAO3ufavzx/aT+N2qfFDWzZWbSWfhy2ci3tg2DKf77+p9B2pf2lfjdqfxQ1trGxeW08N2z/AOj2+cGYj/lo/v6DtXjVfQ4DAKkuefxfkYTnfRBRRQAScAZNeoZhRXv3w2/Zh8V+Lfh7deJprgadcvHv02zlT5rgdcsf4Qe1eHa5pWoaJq1zpWq2ktpeW0hjlikXDKwrOFanUk4xd2htNFKtTwrr+reGNdtta0S8ltL22cPHIhx07H1HtWXRWjSasxH6S/s4/GrSfijoYtp3jtfENqg+1WpON4/vp6j27V69X5IeFfEGr+F9etdc0O9ks7+1cPHKh/QjuD3Ffoj+zl8bNI+KWhLbztFZ+IraMfa7TON+Osieqn07V85j8A6L54fD+RvCd9GevUUUV5hoFVtTvrXTbGW9vJligiXczNRqd9aabYy3t7MsMEQyzMa+ffiN42uvE96YoS0OmxH91F3b/ab3r1spympmFSy0it3+i8z57iDiCjlFG71qPZfq/Id8RPGl14lvTFEzRafGf3cf97/aNclmmZozX6Xh8NTw1NU6askfheNxdbG1pV68ryY/NGTTM16R4J+GVxrGkSX+pSSWfmJ/oq45J7MR6Vni8ZRwkOes7I1y7K8TmNX2WHjd7/0zzvJozV3xDpF7oepyWF/EUkQ8HHDD1FZ+feuiEozipRd0zjq0Z0puE1ZrdE0E8sEyTQu0ciHKspwQa9z+GHjuLXIU0zUpFTUEXCseBKB/WvBs1JBPLBMk0LmORCGVlOCDXn5lllLH0uWWjWz7HsZFnlfJ6/tKesXuu6/z7M+tKK4D4X+PItdhTTNSdY9SQYVicCYDuPf2rv6/M8XhKuEqulVVmj92y7MaGYUFXoO6f4Ps/MKKKK5juCiiigAooooAKKKKACiig9KAM7xLrmleG9EudZ1q8jtLG2QvLK5wAPQep9q/PH9pP43ap8T9beyspJbTw3bSH7NbZx5pH8b+p9u1bH7YPxL8XeJPG114V1G0udH0jT5SIrNuDOR0kbs2e3pXgdfRZfgVTSqT3/IwnO+iCiigAkgAZJr1DMK+s/2TP2d31Brbxz46tNtmMSafp8i8y9/MkB6L0wO9J+yb+zwdSe28b+ObLFmpEljYSr/rT1DuP7voO9faCKqIERQqqMAAYAFeLj8fa9Om/VmsIdWEaJGixooVFGFUDAA9K8Q/ac+BWnfErSZNY0mOO08T2yZilAwtyAPuP/Q9q9worx6VWVKSlF6mrSasfkTrmlahomrXOlaray2l7bSGOaKRcMrCqVfon+098C7D4l6U+s6Skdr4mtY/3UmMC5UdI29/Q1+fOt6XqGi6rcaVqlrJa3ls5SWKQYKkV9RhMXHERut+qOeUeUpVqeFfEGreGNdttb0W7ktb22cNG6HH4H1FZdFdTSasyT9Jf2cPjVpXxR0Fbe4eK18Q2qD7Va7sbx/z0T1H8q9V1O+tdNsZb29mWGCJdzMxr8ovAOoeIdK8W2GoeF5podVhlDQtEefcH2PevsbxP4417xTp1jDq3lQGKFPOigJ2NLj5m59849K4KHD0sTX9x2h18vJHj55xDSyqhd61Hsv1fkaXxG8bXXie9MURaLTo2/dR5+9/tH3rkM1HmjNffYfC08NTVOmrJH4ljMXWxtaVau7yZJmgHmmAmvWfhN8PTceVrmuQkRDDW9uw+9/tN7Vjj8dSwNJ1ar9F3OjK8pr5nXVGivV9Eu7H/Cf4emcx63rkJEfDW9u4+9/tMPT2r2RQFAVQABwAKAAAAAAB0Aor8uzDMKuOq+0qfJdj9zyjKMPlVBUaK9X1bOf8b+FbHxRppt7gCO4UfuZwOUP9R7V86+IdHv8AQtTk0/UIikqHg9mHqD6V9VVz3jnwrY+KNMNvcKEuEBME2OUP+FenkmdywUvZVdab/A8PijheGZw9vQVqq/8AJvJ+fZnzLuo3Ve8Q6Pf6FqclhqERjkQ8Hsw9Qazs1+jwlGpFSi7pn4xVozpTcJqzW6J7eeSCZJoZGjkQhlZTgg17t8LvHsWuQppmpOseooMKxPEw/wAa8DzV3Q7fULvVIIdLWQ3ZcGMx8EH1z2rzs1y2jjaLVTRrZ9v+AezkGcYnK8SpUVzKWjj3/wCD2PrCiqOgx38Oj20eqTJNeLGBK6jAJq9X5VOPLJq9z98pyc4KTVr9H0CiiipLCiiigAooooAKKKKAPK/2hfg3o/xT8PFdsVprlupNnebec/3W9VNfnR4y8Naz4R8RXWg69ZvaXts5V1YcEdmB7g9jX6115V+0P8GtF+Knh05SO0161UmzvQuD/uP6qf0r08DjnRfJP4fyM5wvqj80RycCvrP9kz9ndtRNr458dWTLaAiTT9PlXBl9JJB/d7gd+tXv2bv2Y7yz19vEHxFs1VbKYi1sCQwlZTw7f7PcDvX2CiLGioihVUYAAwAK6cfmGns6T9WTCHVhGiRoqRqFRRgKBgAUtFFeGbBRRRQAV4h+038CtP8AiZpTatpCQ2fia2jPlS4wtyo52P8A0Pavb6K0pVZUpKUXqJq+jPyJ1zStQ0TVrnStVtJbS9tnMcsUgwVIqPS7C61O+isrKFpZ5W2qor9AP2r/AIM6J448OzeJLV7fTtesoyRO3yrcqP4H9/Q14F8OvBlp4XsvMkCTajKP3suM7f8AZX0H86+1yiDzFcy0S3Pms+zqllNLXWb2X6vyH/DnwZaeF7EPIEm1CUDzZcfd/wBke1dfmo80ua+0pUY0oqMVofjWLxNXF1XWrO8mSZozUea9N+B/hTTdau5NUv5opvsrjbak8k9mYelc+OxcMHQlWqbI1y3LqmYYmOHpbvuafwj+HhnMWva5DiMENb27D73ozD09q9oAAAAAAHQCkUBVCqAAOABS1+U5jmNXH1XUqfJdj9yyjKKGV0FRor1fVsKKKK4D1AooooA57xz4UsPFOmG3uFEdwgJgnA5Q/wBR7V84eI9Gv9A1SXT9RhMcqHg/wuOxB7ivrCud8d+E7DxTpZt51CXKDMEwHKn/AAr6LI88lgpeyq603+Hmv1Pj+J+GIZnB16KtVX/k3k/Psz5p0uxu9Tv4rGxheaeVtqIoyTX0T8OPBNp4XsRJKFm1GQfvZf7v+yvtR8OfBFn4UtDIxW41CUfvJsdB/dX0FdfWue568W3RoP3Pz/4BhwvwtHL0sTiVeq9l/L/wQooor5g+3CiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKrarf2ml2E19fTpBbwrud2OAKTVdQtNLsJb6+mWGCJcszGvm34nePLzxXfmGEtDpkTfuos/f/wBpvevZyfJ6uZVbLSC3f6LzPBz3PaOVUbvWb2X6vyH/ABM8d3fiq/MULPDpsR/dRdN3+03vXF5pm6jdX6phsLTw1JUqSskfjGLxVbGVnWrO8mSZ96M0wGnSq8UhjkRkdeCrDBFb2OXlFzWn4b1y/wBA1SPUNPmMciHkdmHoR6Vk7hS596ipTjUi4zV0y6c50pqcHZrZn1X4C8W2HizShc27BLmMATwZ5Q/4V0dfIfhvXL/w/qseo6dMY5U6js47gj0r6Y8BeLtP8WaUtzbER3KAefATyh/qPevzPPshlgJe1pa03+Hk/wBGfr/DfEkcygqNbSqv/JvNefdHSUUUV80fWhRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFVtVv7TS7CW+vp1ht4l3O7HpSatqNnpWny319OsMES7mZjXzP8UfH154tv8AyYWeDS4WPlQ5xvP95vU/yr2smyarmVWy0gt3+i8zws8zylldK71m9l+r8h/xP8eXfiy/MUJaHTIm/cxZ5b/ab3ris0zNGa/V8NhaWFpKlSVkj8bxeKrYuq61Z3kx+aX2pmTXsnwc+GrXBh8Qa/CViB3W9sw5b0Zh6e1YZhj6OAourVfourfY3y3LK+Y11Ror1fRLux3wc+GxuPK1/X4SIgQ1tbuPvf7TD09BXT/Fv4dQ6/bPqukxpFqca5KgYE4Hb6+9ekKAqhVAAHAApa/L62fYupi1ilKzWy6W7f5n63R4bwVPBPBuN0931v3/AMj4wuIZred4J42jlQlWVhgg0zNfRHxc+HUXiCB9W0mNI9TRcso4EwH9a+eLiKW2neCeNo5UO1kYYIPpX6TlOa0cypc8NJLddv8AgH5XnOS1srrck9YvZ9/+CJmtPw1rl/4f1WLUdPmMcqHkZ4Yeh9qys0Zr0qlONSLhNXTPKpznSmpwdmtmfWHgDxfp/i3SVubZhHcoAJ4CfmQ/1HvXSV8feGdd1Dw9q0WpabMY5UPIz8rr3UjuK+nPAHjDT/FulLcW7CO6QYngJ5Q/1FfmGfZBLAS9rS1pv8PJ/oz9c4c4jjmMFRraVV/5N5rz7o6WiiivmT6wKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAOY+JXhRfFvh5rAXDwTod8LA/KW9GHcV8s65pV/oupzadqNu0FxC2GVu/uPUV9m1x/xM8DWHi/TD8qw6jEP3E4HP+6fUV9Tw7n7wEvY1v4b/AAf+Xc+S4k4eWYR9vR/iL8V29ex8q5o+gq9ruk32i6nLp2oQNFPG2CCOvuPUV6v8Gvhk1w0PiDxDBiH71tbOPvejMPT2r9Cx2Z4fB4f283o9rdfQ/OMBlWIxuI+rwjZre/T1F+DPw0NwYfEPiCDEQ+a2tnH3vRmHp6Cvc1AVQqgADgAUKoVQqgAAYAHalr8lzPMq2Y1nVqv0XRI/YsryuhltBUqS9X1bCiiivOPSCvNfi98OYvEVu+raTEseqRrllHAnHoff3r0qiuvBY2tgqyq0nZr8fJnHjsDRx1F0ayun+Hmj4ruIZbad4J42ilQlWRhgg1Hmvoz4vfDiLxDA+raRGseqRjLIOBOP8a8AsdI1K91hdIgtJDetJ5ZiK4Knvn0xX6zleb0Mwoe1Ts1uu3/A8z8dzbJK+XYj2TV0/hff/g+Q3SbC81XUIbCwgee4mYKiKOpr6a+F3ga28IaaWkYTajOo8+Tsv+yvtTPhd4DtPCWnCWULNqcq/vZcfd/2V9q7avh+IeIHjG6FB/u1u+//AAD73hrhuOBSxGIV6j2X8v8AwQooor5M+xCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxdd8LaHrd/a32pWKTT2rbo2Pf2PqK2VAVQqgAAYAHalorSVWc4qMm2lt5GcKNOEnKMUm9/MKKKKzNAooooAKKKKACs+HRdLh1iXV4rKFb6VQrzBfmIrQoqozlG/K7XJlCMrOSvYKKKKkoKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooA//2Q=="), + contactLink = Just adminContactReq, + preferences = Nothing + } timeItToView :: ChatMonad' m => String -> m a -> m a timeItToView s action = do @@ -6345,15 +6358,15 @@ mkValidName = reverse . dropWhile isSpace . fst3 . foldl' addChar ("", '\NUL', 0 fst3 (x, _, _) = x addChar (r, prev, punct) c = if validChar then (c' : r, c', punct') else (r, prev, punct) where - c' = if isSpace c then ' ' else c - punct' - | isPunctuation c = punct + 1 - | isSpace c = punct - | otherwise = 0 - validChar - | c == '\'' = False - | prev == '\NUL' = c > ' ' && c /= '#' && c /= '@' && validFirstChar - | isSpace prev = validFirstChar || (punct == 0 && isPunctuation c) - | isPunctuation prev = validFirstChar || isSpace c || (punct < 3 && isPunctuation c) - | otherwise = validFirstChar || isSpace c || isMark c || isPunctuation c - validFirstChar = isLetter c || isNumber c || isSymbol c + c' = if isSpace c then ' ' else c + punct' + | isPunctuation c = punct + 1 + | isSpace c = punct + | otherwise = 0 + validChar + | c == '\'' = False + | prev == '\NUL' = c > ' ' && c /= '#' && c /= '@' && validFirstChar + | isSpace prev = validFirstChar || (punct == 0 && isPunctuation c) + | isPunctuation prev = validFirstChar || isSpace c || (punct < 3 && isPunctuation c) + | otherwise = validFirstChar || isSpace c || isMark c || isPunctuation c + validFirstChar = isLetter c || isNumber c || isSymbol c diff --git a/src/Simplex/Chat/Archive.hs b/src/Simplex/Chat/Archive.hs index 80307f491..be7b05ea9 100644 --- a/src/Simplex/Chat/Archive.hs +++ b/src/Simplex/Chat/Archive.hs @@ -21,7 +21,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 diff --git a/src/Simplex/Chat/Bot/KnownContacts.hs b/src/Simplex/Chat/Bot/KnownContacts.hs index c079b994a..1ea44d49b 100644 --- a/src/Simplex/Chat/Bot/KnownContacts.hs +++ b/src/Simplex/Chat/Bot/KnownContacts.hs @@ -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) diff --git a/src/Simplex/Chat/Call.hs b/src/Simplex/Chat/Call.hs index 313442838..115cd839e 100644 --- a/src/Simplex/Chat/Call.hs +++ b/src/Simplex/Chat/Call.hs @@ -225,4 +225,3 @@ instance FromField CallState where fromField = fromTextField_ decodeJSON $(J.deriveJSON defaultJSON ''RcvCallInvitation) - diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 3c0054ec1..32f58b54b 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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) diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index c5eb19f28..0706dda08 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -35,9 +35,9 @@ runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController runSimplexChat ChatOpts {maintenance} u cc chat | maintenance = wait =<< async (chat u cc) | otherwise = do - a1 <- runReaderT (startChatController True True True) cc - a2 <- async $ chat u cc - waitEither_ a1 a2 + a1 <- runReaderT (startChatController True True True) cc + a2 <- async $ chat u cc + waitEither_ a1 a2 sendChatCmdStr :: ChatController -> String -> IO ChatResponse sendChatCmdStr cc s = runReaderT (execChatCommand Nothing . encodeUtf8 $ T.pack s) cc diff --git a/src/Simplex/Chat/Files.hs b/src/Simplex/Chat/Files.hs index 845b237cd..9c6d731dd 100644 --- a/src/Simplex/Chat/Files.hs +++ b/src/Simplex/Chat/Files.hs @@ -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) diff --git a/src/Simplex/Chat/Markdown.hs b/src/Simplex/Chat/Markdown.hs index f992b4574..6ee4898e3 100644 --- a/src/Simplex/Chat/Markdown.hs +++ b/src/Simplex/Chat/Markdown.hs @@ -19,7 +19,7 @@ import qualified Data.Attoparsec.Text as A import Data.Char (isDigit, isPunctuation) import Data.Either (fromRight) import Data.Functor (($>)) -import Data.List (intercalate, foldl') +import Data.List (foldl', intercalate) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe, isNothing) @@ -85,16 +85,18 @@ newtype FormatColor = FormatColor Color deriving (Eq, Show) instance FromJSON FormatColor where - parseJSON = J.withText "FormatColor" $ fmap FormatColor . \case - "red" -> pure Red - "green" -> pure Green - "blue" -> pure Blue - "yellow" -> pure Yellow - "cyan" -> pure Cyan - "magenta" -> pure Magenta - "black" -> pure Black - "white" -> pure White - unexpected -> fail $ "unexpected FormatColor: " <> show unexpected + parseJSON = + J.withText "FormatColor" $ + fmap FormatColor . \case + "red" -> pure Red + "green" -> pure Green + "blue" -> pure Blue + "yellow" -> pure Yellow + "cyan" -> pure Cyan + "magenta" -> pure Magenta + "black" -> pure Black + "white" -> pure White + unexpected -> fail $ "unexpected FormatColor: " <> show unexpected instance ToJSON FormatColor where toJSON (FormatColor c) = case c of @@ -167,14 +169,14 @@ markdownP = mconcat <$> A.many' fragmentP md :: Char -> Format -> Text -> Markdown md c f s | T.null s || T.head s == ' ' || T.last s == ' ' = - unmarked $ c `T.cons` s `T.snoc` c + unmarked $ c `T.cons` s `T.snoc` c | otherwise = markdown f s secretP :: Parser Markdown secretP = secret <$> A.takeWhile (== '#') <*> A.takeTill (== '#') <*> A.takeWhile (== '#') secret :: Text -> Text -> Text -> Markdown secret b s a | T.null a || T.null s || T.head s == ' ' || T.last s == ' ' = - unmarked $ '#' `T.cons` ss + unmarked $ '#' `T.cons` ss | otherwise = markdown Secret $ T.init ss where ss = b <> s <> a @@ -215,9 +217,9 @@ markdownP = mconcat <$> A.many' fragmentP wordMD s | T.null s = unmarked s | isUri s = - let t = T.takeWhileEnd isPunctuation s - uri = uriMarkdown $ T.dropWhileEnd isPunctuation s - in if T.null t then uri else uri :|: unmarked t + let t = T.takeWhileEnd isPunctuation s + uri = uriMarkdown $ T.dropWhileEnd isPunctuation s + in if T.null t then uri else uri :|: unmarked t | isEmail s = markdown Email s | otherwise = unmarked s uriMarkdown s = case strDecode $ encodeUtf8 s of diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 709deeb05..c82ecc110 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -10,6 +10,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Messages where @@ -41,7 +42,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, (<$?>)) diff --git a/src/Simplex/Chat/Messages/CIContent.hs b/src/Simplex/Chat/Messages/CIContent.hs index 8d5e2ddd8..6b7e66bdb 100644 --- a/src/Simplex/Chat/Messages/CIContent.hs +++ b/src/Simplex/Chat/Messages/CIContent.hs @@ -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" diff --git a/src/Simplex/Chat/Messages/CIContent/Events.hs b/src/Simplex/Chat/Messages/CIContent/Events.hs index 42a5add1d..16851859e 100644 --- a/src/Simplex/Chat/Messages/CIContent/Events.hs +++ b/src/Simplex/Chat/Messages/CIContent/Events.hs @@ -46,9 +46,9 @@ data SndConnEvent | SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef} deriving (Show) -data RcvDirectEvent = - -- RDEProfileChanged {...} - RDEContactDeleted +data RcvDirectEvent + = -- RDEProfileChanged {...} + RDEContactDeleted deriving (Show) -- platform-specific JSON encoding (used in API) diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 912710254..35e673e8e 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -4,13 +4,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -fobject-code #-} module Simplex.Chat.Mobile where import Control.Concurrent.STM -import Control.Exception (catch, SomeException) +import Control.Exception (SomeException, catch) import Control.Monad.Except import Control.Monad.Reader import qualified Data.Aeson as J @@ -31,7 +30,7 @@ import Foreign.C.Types (CInt (..)) import Foreign.Ptr import Foreign.StablePtr import Foreign.Storable (poke) -import GHC.IO.Encoding (setLocaleEncoding, setFileSystemEncoding, setForeignEncoding) +import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding) import Simplex.Chat import Simplex.Chat.Controller import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList) @@ -219,7 +218,7 @@ chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do ExceptT $ (first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey confirmMigrations) `catch` (pure . checkDBError) - `catchAll` (pure . dbError) + `catchAll` (pure . dbError) where checkDBError e = case sqlError e of DB.ErrorNotADatabase -> Left $ DBMErrorNotADatabase dbFile @@ -233,7 +232,7 @@ chatCloseStore ChatController {chatStore, smpAgent} = handleErr $ do handleErr :: IO () -> IO String handleErr a = (a $> "") `catch` (pure . show @SomeException) - + chatSendCmd :: ChatController -> B.ByteString -> IO JSONByteString chatSendCmd cc = chatSendRemoteCmd cc Nothing diff --git a/src/Simplex/Chat/Mobile/Shared.hs b/src/Simplex/Chat/Mobile/Shared.hs index d1f60ffce..d55ccc796 100644 --- a/src/Simplex/Chat/Mobile/Shared.hs +++ b/src/Simplex/Chat/Mobile/Shared.hs @@ -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 diff --git a/src/Simplex/Chat/Mobile/WebRTC.hs b/src/Simplex/Chat/Mobile/WebRTC.hs index 19ba2b751..588e28545 100644 --- a/src/Simplex/Chat/Mobile/WebRTC.hs +++ b/src/Simplex/Chat/Mobile/WebRTC.hs @@ -1,12 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} -module Simplex.Chat.Mobile.WebRTC ( - cChatEncryptMedia, - cChatDecryptMedia, - chatEncryptMedia, - chatDecryptMedia, - reservedSize, -) where +module Simplex.Chat.Mobile.WebRTC + ( cChatEncryptMedia, + cChatDecryptMedia, + chatEncryptMedia, + chatDecryptMedia, + reservedSize, + ) where import Control.Monad.Except import qualified Crypto.Cipher.Types as AES @@ -19,8 +19,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 diff --git a/src/Simplex/Chat/Options.hs b/src/Simplex/Chat/Options.hs index 7ce6305d2..a6f2b759e 100644 --- a/src/Simplex/Chat/Options.hs +++ b/src/Simplex/Chat/Options.hs @@ -206,7 +206,6 @@ chatOptsP appDir defaultDbFileName = do optional $ strOption ( long "device-name" - <> short 'e' <> metavar "DEVICE" <> help "Device name to use in connections with remote hosts and controller" ) diff --git a/src/Simplex/Chat/ProfileGenerator.hs b/src/Simplex/Chat/ProfileGenerator.hs index 55a051ad8..95f5f1620 100644 --- a/src/Simplex/Chat/ProfileGenerator.hs +++ b/src/Simplex/Chat/ProfileGenerator.hs @@ -18,10 +18,10 @@ generateRandomProfile = do pickNoun adjective n | n == 0 = pick nouns | otherwise = do - noun <- pick nouns - if noun == adjective - then pickNoun adjective (n - 1) - else pure noun + noun <- pick nouns + if noun == adjective + then pickNoun adjective (n - 1) + else pure noun adjectives :: [Text] adjectives = diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 2040941aa..3de7c03e8 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -13,6 +13,7 @@ {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Protocol where diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index e2137b35a..98d7289f9 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -97,24 +97,26 @@ discoveryTimeout = 60000000 getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient getRemoteHostClient rhId = do sessions <- asks remoteHostSessions - liftIOEither . atomically $ TM.lookup rhKey sessions >>= \case - Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient - Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState - Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing + liftIOEither . atomically $ + TM.lookup rhKey sessions >>= \case + Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient + Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState + Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing where rhKey = RHId rhId withRemoteHostSession :: ChatMonad m => RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> m a withRemoteHostSession rhKey sseq f = do sessions <- asks remoteHostSessions - r <- atomically $ - TM.lookup rhKey sessions >>= \case - Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing - Just (stateSeq, state) - | stateSeq /= sseq -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState - | otherwise -> case f state of - Right (r, newState) -> Right r <$ TM.insert rhKey (sseq, newState) sessions - Left ce -> pure $ Left ce + r <- + atomically $ + TM.lookup rhKey sessions >>= \case + Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing + Just (stateSeq, state) + | stateSeq /= sseq -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState + | otherwise -> case f state of + Right (r, newState) -> Right r <$ TM.insert rhKey (sseq, newState) sessions + Left ce -> pure $ Left ce liftEither r -- | Transition session state with a 'RHNew' ID to an assigned 'RemoteHostId' @@ -167,14 +169,16 @@ startRemoteHost rh_ = do when (encoding == PEKotlin && localEncoding == PESwift) $ throwError $ RHEProtocolError RPEIncompatibleEncoding pure hostInfo handleConnectError :: ChatMonad m => RHKey -> SessionSeq -> m a -> m a - handleConnectError rhKey sessSeq action = action `catchChatError` \err -> do - logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err - cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey - throwError err + handleConnectError rhKey sessSeq action = + action `catchChatError` \err -> do + logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err + cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey + throwError err handleHostError :: ChatMonad m => SessionSeq -> TVar RHKey -> m () -> m () - handleHostError sessSeq rhKeyVar action = action `catchChatError` \err -> do - logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err - readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err)) + handleHostError sessSeq rhKeyVar action = + action `catchChatError` \err -> do + logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err + readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err)) waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m () waitForHostSession remoteHost_ rhKey sseq rhKeyVar vars = do (sessId, tls, vars') <- timeoutThrow (ChatErrorRemoteHost rhKey RHETimeout) 60000000 $ takeRCStep vars @@ -250,14 +254,15 @@ cancelRemoteHostSession :: ChatMonad m => Maybe (SessionSeq, RemoteHostStopReaso cancelRemoteHostSession handlerInfo_ rhKey = do sessions <- asks remoteHostSessions crh <- asks currentRemoteHost - deregistered <- atomically $ - TM.lookup rhKey sessions >>= \case - Nothing -> pure Nothing - Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler - Just (_, rhs) -> do - TM.delete rhKey sessions - modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH - pure $ Just rhs + deregistered <- + atomically $ + TM.lookup rhKey sessions >>= \case + Nothing -> pure Nothing + Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler + Just (_, rhs) -> do + TM.delete rhKey sessions + modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH + pure $ Just rhs forM_ deregistered $ \session -> do liftIO $ cancelRemoteHost handlingError session `catchAny` (logError . tshow) forM_ (snd <$> handlerInfo_) $ \rhStopReason -> @@ -401,9 +406,10 @@ findKnownRemoteCtrl = do (RCCtrlPairing {ctrlFingerprint}, inv@(RCVerifiedInvitation RCInvitation {app})) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) discoveryTimeout . withAgent $ \a -> rcDiscoverCtrl a pairings ctrlAppInfo_ <- (Just <$> parseCtrlAppInfo app) `catchChatError` const (pure Nothing) - rc <- withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case - Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl" - Just rc -> pure rc + rc <- + withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case + Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl" + Just rc -> pure rc atomically $ putTMVar foundCtrl (rc, inv) let compatible = isJust $ compatibleAppVersion hostAppVersionRange . appVersionRange =<< ctrlAppInfo_ toView CRRemoteCtrlFound {remoteCtrl = remoteCtrlInfo rc (Just RCSSearching), ctrlAppInfo_, appVersion = currentAppVersion, compatible} @@ -422,7 +428,7 @@ confirmRemoteCtrl rcId = do pure $ Right (sseq, action, foundCtrl) _ -> pure . Left $ ChatErrorRemoteCtrl RCEBadState uninterruptibleCancel listener - (RemoteCtrl{remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found + (RemoteCtrl {remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found unless (rcId == foundRcId) $ throwError $ ChatErrorRemoteCtrl RCEBadController connectRemoteCtrl verifiedInv sseq >>= \case (Nothing, _) -> throwChatError $ CEInternalError "connecting with a stored ctrl" @@ -647,10 +653,12 @@ handleCtrlError sseq mkReason name action = cancelActiveRemoteCtrl :: ChatMonad m => Maybe (SessionSeq, RemoteCtrlStopReason) -> m () cancelActiveRemoteCtrl handlerInfo_ = handleAny (logError . tshow) $ do var <- asks remoteCtrlSession - session_ <- atomically $ readTVar var >>= \case - Nothing -> pure Nothing - Just (oldSeq, _) | maybe False (/= oldSeq) (fst <$> handlerInfo_) -> pure Nothing - Just (_, s) -> Just s <$ writeTVar var Nothing + session_ <- + atomically $ + readTVar var >>= \case + Nothing -> pure Nothing + Just (oldSeq, _) | (maybe False ((oldSeq /=) . fst) handlerInfo_) -> pure Nothing + Just (_, s) -> Just s <$ writeTVar var Nothing forM_ session_ $ \session -> do liftIO $ cancelRemoteCtrl handlingError session forM_ (snd <$> handlerInfo_) $ \rcStopReason -> diff --git a/src/Simplex/Chat/Remote/AppVersion.hs b/src/Simplex/Chat/Remote/AppVersion.hs index e39a64b0a..ad9f16e1b 100644 --- a/src/Simplex/Chat/Remote/AppVersion.hs +++ b/src/Simplex/Chat/Remote/AppVersion.hs @@ -11,7 +11,7 @@ module Simplex.Chat.Remote.AppVersion compatibleAppVersion, isAppCompatible, ) - where +where import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as J diff --git a/src/Simplex/Chat/Remote/Multicast.hsc b/src/Simplex/Chat/Remote/Multicast.hsc index 3919b4423..2303bd970 100644 --- a/src/Simplex/Chat/Remote/Multicast.hsc +++ b/src/Simplex/Chat/Remote/Multicast.hsc @@ -6,10 +6,8 @@ import Network.Socket #include -{- | 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 diff --git a/src/Simplex/Chat/Remote/Protocol.hs b/src/Simplex/Chat/Remote/Protocol.hs index c1acee1e0..af4c7d33e 100644 --- a/src/Simplex/Chat/Remote/Protocol.hs +++ b/src/Simplex/Chat/Remote/Protocol.hs @@ -6,8 +6,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module Simplex.Chat.Remote.Protocol where @@ -41,16 +41,16 @@ import Simplex.FileTransfer.Description (FileDigest (..)) import Simplex.Messaging.Agent.Client (agentDRG) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..)) -import Simplex.Messaging.Crypto.Lazy (LazyByteString) +import Simplex.Messaging.Crypto.Lazy (LazyByteString) import Simplex.Messaging.Encoding import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON, pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag) import Simplex.Messaging.Transport.Buffer (getBuffered) import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect) import Simplex.Messaging.Util (liftEitherError, liftEitherWith, liftError, tshow) -import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode) import Simplex.RemoteControl.Client (xrcpBlockSize) import qualified Simplex.RemoteControl.Client as RC +import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode) import System.FilePath (takeFileName, ()) import UnliftIO @@ -64,10 +64,10 @@ data RemoteCommand data RemoteResponse = RRChatResponse {chatResponse :: ChatResponse} - | RRChatEvent {chatEvent :: Maybe ChatResponse} -- ^ 'Nothing' on poll timeout + | RRChatEvent {chatEvent :: Maybe ChatResponse} -- 'Nothing' on poll timeout | RRFileStored {filePath :: String} | RRFile {fileSize :: Word32, fileDigest :: FileDigest} -- provides attachment , fileDigest :: FileDigest - | RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- ^ The protocol error happened on the server side + | RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- The protocol error happened on the server side deriving (Show) -- Force platform-independent encoding as the types aren't UI-visible @@ -126,7 +126,7 @@ remoteStoreFile c localPath fileName = do r -> badResponse r remoteGetFile :: RemoteHostClient -> FilePath -> RemoteFile -> ExceptT RemoteProtocolError IO () -remoteGetFile c@RemoteHostClient{encryption} destDir rf@RemoteFile {fileSource = CryptoFile {filePath}} = +remoteGetFile c@RemoteHostClient {encryption} destDir rf@RemoteFile {fileSource = CryptoFile {filePath}} = sendRemoteCommand c Nothing RCGetFile {file = rf} >>= \case (getChunk, RRFile {fileSize, fileDigest}) -> do -- TODO we could optimize by checking size and hash before receiving the file @@ -140,7 +140,7 @@ sendRemoteCommand' c attachment_ rc = snd <$> sendRemoteCommand c attachment_ rc sendRemoteCommand :: RemoteHostClient -> Maybe (Handle, Word32) -> RemoteCommand -> ExceptT RemoteProtocolError IO (Int -> IO ByteString, RemoteResponse) sendRemoteCommand RemoteHostClient {httpClient, hostEncoding, encryption} file_ cmd = do - encFile_ <- mapM (prepareEncryptedFile encryption) file_ + encFile_ <- mapM (prepareEncryptedFile encryption) file_ req <- httpRequest encFile_ <$> encryptEncodeHTTP2Body encryption (J.encode cmd) HTTP2Response {response, respBody} <- liftEitherError (RPEHTTP2 . tshow) $ sendRequestDirect httpClient req Nothing (header, getNext) <- parseDecryptHTTP2Body encryption response respBody diff --git a/src/Simplex/Chat/Remote/Transport.hs b/src/Simplex/Chat/Remote/Transport.hs index c5ddfbdb8..ccd10b328 100644 --- a/src/Simplex/Chat/Remote/Transport.hs +++ b/src/Simplex/Chat/Remote/Transport.hs @@ -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 (..)) diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index 783a083e5..8411ceea0 100644 --- a/src/Simplex/Chat/Remote/Types.hs +++ b/src/Simplex/Chat/Remote/Types.hs @@ -21,13 +21,13 @@ import Data.Text (Text) import Simplex.Chat.Remote.AppVersion import Simplex.Chat.Types (verificationCode) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.File (CryptoFile) import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON) +import Simplex.Messaging.Transport (TLS (..)) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) import Simplex.RemoteControl.Client import Simplex.RemoteControl.Types -import Simplex.Messaging.Crypto.File (CryptoFile) -import Simplex.Messaging.Transport (TLS (..)) data RemoteHostClient = RemoteHostClient { hostEncoding :: PlatformEncoding, @@ -48,13 +48,13 @@ data RemoteCrypto = RemoteCrypto data RemoteSignatures = RSSign - { idPrivKey :: C.PrivateKeyEd25519, - sessPrivKey :: C.PrivateKeyEd25519 - } + { idPrivKey :: C.PrivateKeyEd25519, + sessPrivKey :: C.PrivateKeyEd25519 + } | RSVerify - { idPubKey :: C.PublicKeyEd25519, - sessPubKey :: C.PublicKeyEd25519 - } + { idPubKey :: C.PublicKeyEd25519, + sessPubKey :: C.PublicKeyEd25519 + } type SessionSeq = Int @@ -71,12 +71,12 @@ data RemoteHostSession | RHSessionPendingConfirmation {sessionCode :: Text, tls :: TLS, rhPendingSession :: RHPendingSession} | RHSessionConfirmed {tls :: TLS, rhPendingSession :: RHPendingSession} | RHSessionConnected - { rchClient :: RCHostClient, - tls :: TLS, - rhClient :: RemoteHostClient, - pollAction :: Async (), - storePath :: FilePath - } + { rchClient :: RCHostClient, + tls :: TLS, + rhClient :: RemoteHostClient, + pollAction :: Async (), + storePath :: FilePath + } data RemoteHostSessionState = RHSStarting diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs index e710a1d59..019f2bae0 100644 --- a/src/Simplex/Chat/Store/Connections.hs +++ b/src/Simplex/Chat/Store/Connections.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Store.Connections ( getConnectionEntity, @@ -22,11 +23,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) @@ -154,8 +155,9 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity) getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do - connId_ <- maybeFirstRow fromOnly $ - DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2) + connId_ <- + maybeFirstRow fromOnly $ + DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2) maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_ -- search connection for connection plan: @@ -164,21 +166,22 @@ getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = -- deleted connections are filtered out to allow re-connecting via same contact address getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity) getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do - connId_ <- maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT agent_conn_id FROM ( - SELECT - agent_conn_id, - (CASE WHEN contact_id IS NOT NULL THEN 1 ELSE 0 END) AS conn_ord - FROM connections - WHERE user_id = ? AND via_contact_uri_hash IN (?,?) AND conn_status != ? - ORDER BY conn_ord DESC, created_at DESC - LIMIT 1 - ) - |] - (userId, cReqHash1, cReqHash2, ConnDeleted) + connId_ <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT agent_conn_id FROM ( + SELECT + agent_conn_id, + (CASE WHEN contact_id IS NOT NULL THEN 1 ELSE 0 END) AS conn_ord + FROM connections + WHERE user_id = ? AND via_contact_uri_hash IN (?,?) AND conn_status != ? + ORDER BY conn_ord DESC, created_at DESC + LIMIT 1 + ) + |] + (userId, cReqHash1, cReqHash2, ConnDeleted) maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_ getConnectionsToSubscribe :: DB.Connection -> IO ([ConnId], [ConnectionEntity]) diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index d733d536b..427a5842f 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -6,6 +6,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Store.Direct ( updateContact_, @@ -305,14 +306,14 @@ deleteUnusedProfile_ db userId profileId = updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact updateContactProfile db user@User {userId} c p' | displayName == newName = do - liftIO $ updateContactProfile_ db userId profileId p' - pure c {profile, mergedPreferences} + liftIO $ updateContactProfile_ db userId profileId p' + pure c {profile, mergedPreferences} | otherwise = - ExceptT . withLocalDisplayName db userId newName $ \ldn -> do - currentTs <- getCurrentTime - updateContactProfile_' db userId profileId p' currentTs - updateContact_ db userId contactId localDisplayName ldn currentTs - pure $ Right c {localDisplayName = ldn, profile, mergedPreferences} + ExceptT . withLocalDisplayName db userId newName $ \ldn -> do + currentTs <- getCurrentTime + updateContactProfile_' db userId profileId p' currentTs + updateContact_ db userId contactId localDisplayName ldn currentTs + pure $ Right c {localDisplayName = ldn, profile, mergedPreferences} where Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, userPreferences} = c Profile {displayName = newName, preferences} = p' @@ -779,10 +780,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} = @@ -811,4 +810,3 @@ resetContactConnInitiated db User {userId} Connection {connId} = do WHERE user_id = ? AND connection_id = ? |] (updatedAt, userId, connId) - diff --git a/src/Simplex/Chat/Store/Files.hs b/src/Simplex/Chat/Store/Files.hs index 996a44b06..927f4b947 100644 --- a/src/Simplex/Chat/Store/Files.hs +++ b/src/Simplex/Chat/Store/Files.hs @@ -106,7 +106,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 @@ -129,7 +129,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 @@ -231,11 +231,12 @@ createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Conn updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> ExceptT StoreError IO () updateSndDirectFTDelivery _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName -updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = liftIO $ - DB.execute - db - "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" - (msgDeliveryId, connId, fileId) +updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = + liftIO $ + DB.execute + db + "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" + (msgDeliveryId, connId, fileId) updateSndGroupFTDelivery :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> Int64 -> IO () updateSndGroupFTDelivery db GroupMember {groupMemberId} Connection {connId} FileTransferMeta {fileId} msgDeliveryId = @@ -721,7 +722,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 @@ -765,20 +766,20 @@ createRcvFileChunk db RcvFileTransfer {fileId, fileInvitation = FileInvitation { pure $ case map fromOnly ns of [] | chunkNo == 1 -> - if chunkSize >= fileSize - then RcvChunkFinal - else RcvChunkOk + if chunkSize >= fileSize + then RcvChunkFinal + else RcvChunkOk | otherwise -> RcvChunkError n : _ | chunkNo == n -> RcvChunkDuplicate | chunkNo == n + 1 -> - let prevSize = n * chunkSize - in if prevSize >= fileSize - then RcvChunkError - else - if prevSize + chunkSize >= fileSize - then RcvChunkFinal - else RcvChunkOk + let prevSize = n * chunkSize + in if prevSize >= fileSize + then RcvChunkError + else + if prevSize + chunkSize >= fileSize + then RcvChunkFinal + else RcvChunkOk | otherwise -> RcvChunkError updatedRcvFileChunkStored :: DB.Connection -> RcvFileTransfer -> Integer -> IO () diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index d71ea80c8..09aef8b91 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Store.Groups ( -- * Util methods @@ -117,7 +118,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) @@ -441,39 +442,39 @@ createGroupInvitedViaLink void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs supportedChatVRange liftIO $ setViaGroupLinkHash db groupId connId (,) <$> getGroupInfo db user groupId <*> getGroupMemberById db user hostMemberId - where - insertGroup_ currentTs = ExceptT $ do - let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile - withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do - liftIO $ do - DB.execute - db - "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) - profileId <- insertedRowId db - DB.execute - db - "INSERT INTO groups (group_profile_id, local_display_name, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?)" - (profileId, localDisplayName, customUserProfileId, userId, True, currentTs, currentTs, currentTs) - insertedRowId db - insertHost_ currentTs groupId = ExceptT $ do - let fromMemberProfile = profileFromName fromMemberName - withLocalDisplayName db userId fromMemberName $ \localDisplayName -> runExceptT $ do - (_, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs - let MemberIdRole {memberId, memberRole} = fromMember - liftIO $ do - DB.execute - db - [sql| - INSERT INTO group_members - ( group_id, member_id, member_role, member_category, member_status, invited_by, - user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?) - |] - ( (groupId, memberId, memberRole, GCHostMember, GSMemAccepted, fromInvitedBy userContactId IBUnknown) - :. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs) - ) - insertedRowId db + where + insertGroup_ currentTs = ExceptT $ do + let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile + withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do + liftIO $ do + DB.execute + db + "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) + profileId <- insertedRowId db + DB.execute + db + "INSERT INTO groups (group_profile_id, local_display_name, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?)" + (profileId, localDisplayName, customUserProfileId, userId, True, currentTs, currentTs, currentTs) + insertedRowId db + insertHost_ currentTs groupId = ExceptT $ do + let fromMemberProfile = profileFromName fromMemberName + withLocalDisplayName db userId fromMemberName $ \localDisplayName -> runExceptT $ do + (_, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs + let MemberIdRole {memberId, memberRole} = fromMember + liftIO $ do + DB.execute + db + [sql| + INSERT INTO group_members + ( group_id, member_id, member_role, member_category, member_status, invited_by, + user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (groupId, memberId, memberRole, GCHostMember, GSMemAccepted, fromInvitedBy userContactId IBUnknown) + :. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs) + ) + insertedRowId db setViaGroupLinkHash :: DB.Connection -> GroupId -> Int64 -> IO () setViaGroupLinkHash db groupId connId = @@ -809,22 +810,22 @@ createAcceptedMember insertMember_ (MemberId memId) createdAt groupMemberId <- liftIO $ insertedRowId db pure (groupMemberId, MemberId memId) - where - JVersionRange (VersionRange minV maxV) = cReqChatVRange - insertMember_ memberId createdAt = - DB.execute - db - [sql| - INSERT INTO group_members - ( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id, - user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at, - peer_chat_min_version, peer_chat_max_version) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) - |] - ( (groupId, memberId, memberRole, GCInviteeMember, GSMemAccepted, fromInvitedBy userContactId IBUser, groupMemberId' membership) - :. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, createdAt, createdAt) - :. (minV, maxV) - ) + where + JVersionRange (VersionRange minV maxV) = cReqChatVRange + insertMember_ memberId createdAt = + DB.execute + db + [sql| + INSERT INTO group_members + ( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id, + user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at, + peer_chat_min_version, peer_chat_max_version) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (groupId, memberId, memberRole, GCInviteeMember, GSMemAccepted, fromInvitedBy userContactId IBUser, groupMemberId' membership) + :. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, createdAt, createdAt) + :. (minV, maxV) + ) createAcceptedMemberConnection :: DB.Connection -> User -> (CommandId, ConnId) -> UserContactRequest -> GroupMemberId -> SubscriptionMode -> IO () createAcceptedMemberConnection @@ -952,23 +953,24 @@ createNewMember_ :. (minV, maxV) ) groupMemberId <- insertedRowId db - pure GroupMember { - groupMemberId, - groupId, - memberId, - memberRole, - memberCategory, - memberStatus, - memberSettings = defaultMemberSettings, - invitedBy, - invitedByGroupMemberId = memInvitedByGroupMemberId, - localDisplayName, - memberProfile = toLocalProfile memberContactProfileId memberProfile "", - memberContactId, - memberContactProfileId, - activeConn, - memberChatVRange = JVersionRange mcvr - } + pure + GroupMember + { groupMemberId, + groupId, + memberId, + memberRole, + memberCategory, + memberStatus, + memberSettings = defaultMemberSettings, + invitedBy, + invitedByGroupMemberId = memInvitedByGroupMemberId, + localDisplayName, + memberProfile = toLocalProfile memberContactProfileId memberProfile "", + memberContactId, + memberContactProfileId, + activeConn, + memberChatVRange = JVersionRange mcvr + } checkGroupMemberHasItems :: DB.Connection -> User -> GroupMember -> IO (Maybe ChatItemId) checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} = @@ -1099,41 +1101,41 @@ getForwardIntroducedMembers :: DB.Connection -> User -> GroupMember -> Bool -> I getForwardIntroducedMembers db user invitee highlyAvailable = do memberIds <- map fromOnly <$> query filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds - where - mId = groupMemberId' invitee - query - | highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected) - | otherwise = - DB.query - db - (q <> " AND intro_chat_protocol_version >= ?") - (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange) - q = - [sql| - SELECT re_group_member_id - FROM group_member_intros - WHERE to_group_member_id = ? AND intro_status NOT IN (?,?,?) - |] + where + mId = groupMemberId' invitee + query + | highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected) + | otherwise = + DB.query + db + (q <> " AND intro_chat_protocol_version >= ?") + (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange) + q = + [sql| + SELECT re_group_member_id + FROM group_member_intros + WHERE to_group_member_id = ? AND intro_status NOT IN (?,?,?) + |] getForwardInvitedMembers :: DB.Connection -> User -> GroupMember -> Bool -> IO [GroupMember] getForwardInvitedMembers db user forwardMember highlyAvailable = do memberIds <- map fromOnly <$> query filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds - where - mId = groupMemberId' forwardMember - query - | highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected) - | otherwise = - DB.query - db - (q <> " AND intro_chat_protocol_version >= ?") - (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange) - q = - [sql| - SELECT to_group_member_id - FROM group_member_intros - WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?) - |] + where + mId = groupMemberId' forwardMember + query + | highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected) + | otherwise = + DB.query + db + (q <> " AND intro_chat_protocol_version >= ?") + (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange) + q = + [sql| + SELECT to_group_member_id + FROM group_member_intros + WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?) + |] createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do @@ -1258,15 +1260,15 @@ getViaGroupContact db user@User {userId} GroupMember {groupMemberId} = do updateGroupProfile :: DB.Connection -> User -> GroupInfo -> GroupProfile -> ExceptT StoreError IO GroupInfo updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, description, image, groupPreferences} | displayName == newName = liftIO $ do - currentTs <- getCurrentTime - updateGroupProfile_ currentTs - pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences} - | otherwise = - ExceptT . withLocalDisplayName db userId newName $ \ldn -> do currentTs <- getCurrentTime updateGroupProfile_ currentTs - updateGroup_ ldn currentTs - pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences} + pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences} + | otherwise = + ExceptT . withLocalDisplayName db userId newName $ \ldn -> do + currentTs <- getCurrentTime + updateGroupProfile_ currentTs + updateGroup_ ldn currentTs + pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences} where fullGroupPreferences = mergeGroupPreferences groupPreferences updateGroupProfile_ currentTs = @@ -1312,31 +1314,33 @@ getGroupInfo db User {userId, userContactId} groupId = getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo) getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do - groupId_ <- maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT group_id - FROM user_contact_links - WHERE user_id = ? AND conn_req_contact IN (?,?) - |] - (userId, cReqSchema1, cReqSchema2) + groupId_ <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT group_id + FROM user_contact_links + WHERE user_id = ? AND conn_req_contact IN (?,?) + |] + (userId, cReqSchema1, cReqSchema2) maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_ getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo) getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do - groupId_ <- maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT g.group_id - FROM groups g - JOIN group_members mu ON mu.group_id = g.group_id - WHERE g.user_id = ? AND g.via_group_link_uri_hash IN (?,?) - AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?) - LIMIT 1 - |] - (userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) + groupId_ <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT g.group_id + FROM groups g + JOIN group_members mu ON mu.group_id = g.group_id + WHERE g.user_id = ? AND g.via_group_link_uri_hash IN (?,?) + AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?) + LIMIT 1 + |] + (userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_ getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId @@ -1930,18 +1934,18 @@ createMemberContactConn_ updateMemberProfile :: DB.Connection -> User -> GroupMember -> Profile -> ExceptT StoreError IO GroupMember updateMemberProfile db User {userId} m p' | displayName == newName = do - liftIO $ updateContactProfile_ db userId profileId p' - pure m {memberProfile = profile} + liftIO $ updateContactProfile_ db userId profileId p' + pure m {memberProfile = profile} | otherwise = - ExceptT . withLocalDisplayName db userId newName $ \ldn -> do - currentTs <- getCurrentTime - updateContactProfile_' db userId profileId p' currentTs - DB.execute - db - "UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?" - (ldn, currentTs, userId, groupMemberId) - DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) - pure $ Right m {localDisplayName = ldn, memberProfile = profile} + ExceptT . withLocalDisplayName db userId newName $ \ldn -> do + currentTs <- getCurrentTime + updateContactProfile_' db userId profileId p' currentTs + DB.execute + db + "UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?" + (ldn, currentTs, userId, groupMemberId) + DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) + pure $ Right m {localDisplayName = ldn, memberProfile = profile} where GroupMember {groupMemberId, localDisplayName, memberProfile = LocalProfile {profileId, displayName, localAlias}} = m Profile {displayName = newName} = p' diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 8e1684259..145ae11e3 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Store.Messages ( getContactConnIds_, @@ -195,40 +196,41 @@ createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMs createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs pure msg -createNewRcvMessage :: forall e. (MsgEncodingI e) => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage -createNewRcvMessage db connOrGroupId NewMessage{chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember = +createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage +createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember = case connOrGroupId of ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing GroupId groupId -> case sharedMsgId_ of - Just sharedMsgId -> liftIO (duplicateGroupMsgMemberIds groupId sharedMsgId) >>= \case - Just (duplAuthorId, duplFwdMemberId) -> - throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId - Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId + Just sharedMsgId -> + liftIO (duplicateGroupMsgMemberIds groupId sharedMsgId) >>= \case + Just (duplAuthorId, duplFwdMemberId) -> + throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId + Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId - where - duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId)) - duplicateGroupMsgMemberIds groupId sharedMsgId = - maybeFirstRow id - $ DB.query + where + duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId)) + duplicateGroupMsgMemberIds groupId sharedMsgId = + maybeFirstRow id $ + DB.query + db + [sql| + SELECT author_group_member_id, forwarded_by_group_member_id + FROM messages + WHERE group_id = ? AND shared_msg_id = ? LIMIT 1 + |] + (groupId, sharedMsgId) + insertRcvMsg connId_ groupId_ = do + currentTs <- getCurrentTime + DB.execute db [sql| - SELECT author_group_member_id, forwarded_by_group_member_id - FROM messages - WHERE group_id = ? AND shared_msg_id = ? LIMIT 1 + INSERT INTO messages + (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id) + VALUES (?,?,?,?,?,?,?,?,?,?) |] - (groupId, sharedMsgId) - insertRcvMsg connId_ groupId_ = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - INSERT INTO messages - (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id) - VALUES (?,?,?,?,?,?,?,?,?,?) - |] - (MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember) - msgId <- insertedRowId db - pure RcvMessage{msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember} + (MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember) + msgId <- insertedRowId db + pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember} createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO () createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do @@ -1798,22 +1800,22 @@ getDirectReactions db ct itemSharedMId sent = setDirectReaction :: DB.Connection -> Contact -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO () setDirectReaction db ct itemSharedMId sent reaction add msgId reactionTs | add = - DB.execute - db - [sql| - INSERT INTO chat_item_reactions - (contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) - VALUES (?,?,?,?,?,?) - |] - (contactId' ct, itemSharedMId, sent, reaction, msgId, reactionTs) + DB.execute + db + [sql| + INSERT INTO chat_item_reactions + (contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) + VALUES (?,?,?,?,?,?) + |] + (contactId' ct, itemSharedMId, sent, reaction, msgId, reactionTs) | otherwise = - DB.execute - db - [sql| - DELETE FROM chat_item_reactions - WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ? - |] - (contactId' ct, itemSharedMId, sent, reaction) + DB.execute + db + [sql| + DELETE FROM chat_item_reactions + WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ? + |] + (contactId' ct, itemSharedMId, sent, reaction) getGroupReactions :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> IO [MsgReaction] getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent = @@ -1830,22 +1832,22 @@ getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent = setGroupReaction :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO () setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reaction add msgId reactionTs | add = - DB.execute - db - [sql| - INSERT INTO chat_item_reactions - (group_id, group_member_id, item_member_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) - VALUES (?,?,?,?,?,?,?,?) - |] - (groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent, reaction, msgId, reactionTs) + DB.execute + db + [sql| + INSERT INTO chat_item_reactions + (group_id, group_member_id, item_member_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) + VALUES (?,?,?,?,?,?,?,?) + |] + (groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent, reaction, msgId, reactionTs) | otherwise = - DB.execute - db - [sql| - DELETE FROM chat_item_reactions - WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ? - |] - (groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction) + DB.execute + db + [sql| + DELETE FROM chat_item_reactions + WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ? + |] + (groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction) getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)] getTimedItems db User {userId} startTimedThreadCutoff = diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index fbc093062..35a990056 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Store.Profiles ( AutoAccept (..), @@ -63,9 +64,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) @@ -86,7 +87,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 @@ -245,19 +246,19 @@ updateUserGroupReceipts db User {userId} UserMsgReceiptSettings {enable, clearOv updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User updateUserProfile db user p' | displayName == newName = do - liftIO $ updateContactProfile_ db userId profileId p' - pure user {profile, fullPreferences} + liftIO $ updateContactProfile_ db userId profileId p' + pure user {profile, fullPreferences} | otherwise = - checkConstraint SEDuplicateName . liftIO $ do - currentTs <- getCurrentTime - DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId) - DB.execute - db - "INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (newName, newName, userId, currentTs, currentTs) - updateContactProfile_' db userId profileId p' currentTs - updateContact_ db userId userContactId localDisplayName newName currentTs - pure user {localDisplayName = newName, profile, fullPreferences} + checkConstraint SEDuplicateName . liftIO $ do + currentTs <- getCurrentTime + DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId) + DB.execute + db + "INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (newName, newName, userId, currentTs, currentTs) + updateContactProfile_' db userId profileId p' currentTs + updateContact_ db userId userContactId localDisplayName newName currentTs + pure user {localDisplayName = newName, profile, fullPreferences} where User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}} = user Profile {displayName = newName, preferences} = p' @@ -454,17 +455,18 @@ getUserContactLinkByConnReq db User {userId} (cReqSchema1, cReqSchema2) = getContactWithoutConnViaAddress :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact) getContactWithoutConnViaAddress db user@User {userId} (cReqSchema1, cReqSchema2) = do - ctId_ <- maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT ct.contact_id - FROM contacts ct - JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id - LEFT JOIN connections c ON c.contact_id = ct.contact_id - WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL - |] - (userId, cReqSchema1, cReqSchema2) + ctId_ <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT ct.contact_id + FROM contacts ct + JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id + LEFT JOIN connections c ON c.contact_id = ct.contact_id + WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL + |] + (userId, cReqSchema1, cReqSchema2) maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db user) ctId_ updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index 9d2da138b..f07a89d33 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -99,7 +99,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 diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index eea693da4..31d75f52d 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -193,19 +193,19 @@ receiveFromTTY cc@ChatController {inputQ, currentUser, currentRemoteHost, chatSt case lm_ of Just LiveMessage {chatName} | live -> do - writeTVar termState ts' {previousInput} - writeTBQueue inputQ $ "/live " <> chatNameStr chatName + writeTVar termState ts' {previousInput} + writeTBQueue inputQ $ "/live " <> chatNameStr chatName | otherwise -> - writeTVar termState ts' {inputPrompt = "> ", previousInput} + writeTVar termState ts' {inputPrompt = "> ", previousInput} where previousInput = chatNameStr chatName <> " " <> s _ | live -> when (isSend s) $ do - writeTVar termState ts' {previousInput = s} - writeTBQueue inputQ $ "/live " <> s + writeTVar termState ts' {previousInput = s} + writeTBQueue inputQ $ "/live " <> s | otherwise -> do - writeTVar termState ts' {inputPrompt = "> ", previousInput = s} - writeTBQueue inputQ s + writeTVar termState ts' {inputPrompt = "> ", previousInput = s} + writeTBQueue inputQ s pure $ (s,) <$> lm_ where isSend s = length s > 1 && (head s == '@' || head s == '#') @@ -342,9 +342,9 @@ updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputStr charsWithContact cs | live = cs | null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" && cs /= "\\" && cs /= "!" && cs /= "+" && cs /= "-" = - chatPrefix <> cs + chatPrefix <> cs | (s == ">" || s == "\\" || s == "!") && cs == " " = - cs <> chatPrefix + cs <> chatPrefix | otherwise = cs insertChars = ts' . if p >= length s then append else insert append cs = let s' = s <> cs in (s', length s') @@ -380,13 +380,13 @@ updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputStr prevWordPos | p == 0 || null s = p | otherwise = - let before = take p s - beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before - in max 0 $ p - length before + length beforeWord + let before = take p s + beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before + in max 0 $ p - length before + length beforeWord nextWordPos | p >= length s || null s = p | otherwise = - let after = drop p s - afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after - in min (length s) $ p + length after - length afterWord + let after = drop p s + afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after + in min (length s) $ p + length after - length afterWord ts' (s', p') = ts {inputString = s', inputPosition = p', autoComplete = acp {acTabPressed = False}} diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index 0adb4999a..4fa6931f5 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -24,7 +24,7 @@ import Simplex.Chat (execChatCommand, processChatCommand) import Simplex.Chat.Controller import Simplex.Chat.Markdown import Simplex.Chat.Messages -import Simplex.Chat.Messages.CIContent (CIContent(..), SMsgDirection (..)) +import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..)) import Simplex.Chat.Options import Simplex.Chat.Protocol (MsgContent (..), msgContentText) import Simplex.Chat.Remote.Types (RHKey (..), RemoteHostId, RemoteHostInfo (..), RemoteHostSession (..)) @@ -167,9 +167,10 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc _ -> pure () logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s - getRemoteUser rhId = runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case - CRActiveUser {user} -> updateRemoteUser ct user rhId - cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr + getRemoteUser rhId = + runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case + CRActiveUser {user} -> updateRemoteUser ct user rhId + cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr removeRemoteUser rhId = atomically $ TM.delete rhId (currentRemoteUsers ct) responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO () @@ -326,9 +327,9 @@ updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessag clearLines from till | from >= till = return () | otherwise = do - setCursorPosition $ Position {row = from, col = 0} - eraseInLine EraseForward - clearLines (from + 1) till + setCursorPosition $ Position {row = from, col = 0} + eraseInLine EraseForward + clearLines (from + 1) till inputHeight :: TerminalState -> Int inputHeight ts = length (autoCompletePrefix ts <> inputPrompt ts <> inputString ts) `div` width + 1 autoCompletePrefix :: TerminalState -> String diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index ddeee38d8..aaa455129 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -38,7 +38,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 (..)) @@ -48,7 +48,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 @@ -496,7 +496,7 @@ data LocalProfile = LocalProfile deriving (Eq, Show) localProfileId :: LocalProfile -> ProfileId -localProfileId = profileId +localProfileId LocalProfile {profileId} = profileId toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile toLocalProfile profileId Profile {displayName, fullName, image, contactLink, preferences} localAlias = diff --git a/src/Simplex/Chat/Types/Util.hs b/src/Simplex/Chat/Types/Util.hs index fffdd24b9..0f41931ac 100644 --- a/src/Simplex/Chat/Types/Util.hs +++ b/src/Simplex/Chat/Types/Util.hs @@ -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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 604c5ea54..d7617edaf 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -13,8 +13,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) @@ -43,8 +43,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 @@ -307,10 +307,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} -> @@ -510,42 +510,43 @@ viewChats ts tz = concatMap chatPreview . reverse viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString] viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember}, content, quotedItem, file} doShow ts tz = - withGroupMsgForwarded . withItemDeleted <$> (case chat of - DirectChat c -> case chatDir of - CIDirectSnd -> case content of - CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc - CISndGroupEvent {} -> showSndItemProhibited to - _ -> showSndItem to - where - to = ttyToContact' c - CIDirectRcv -> case content of - CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc - CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta - CIRcvGroupEvent {} -> showRcvItemProhibited from - _ -> showRcvItem from - where - from = ttyFromContact c - where - quote = maybe [] (directQuote chatDir) quotedItem - GroupChat g -> case chatDir of - CIGroupSnd -> case content of - CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc - CISndGroupInvitation {} -> showSndItemProhibited to - _ -> showSndItem to - where - to = ttyToGroup g - CIGroupRcv m -> case content of - CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc - CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta - CIRcvGroupInvitation {} -> showRcvItemProhibited from - CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False - _ -> showRcvItem from - where - from = ttyFromGroup g m - where - quote = maybe [] (groupQuote g) quotedItem - _ -> []) + withGroupMsgForwarded . withItemDeleted <$> viewCI where + viewCI = case chat of + DirectChat c -> case chatDir of + CIDirectSnd -> case content of + CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc + CISndGroupEvent {} -> showSndItemProhibited to + _ -> showSndItem to + where + to = ttyToContact' c + CIDirectRcv -> case content of + CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc + CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta + CIRcvGroupEvent {} -> showRcvItemProhibited from + _ -> showRcvItem from + where + from = ttyFromContact c + where + quote = maybe [] (directQuote chatDir) quotedItem + GroupChat g -> case chatDir of + CIGroupSnd -> case content of + CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc + CISndGroupInvitation {} -> showSndItemProhibited to + _ -> showSndItem to + where + to = ttyToGroup g + CIGroupRcv m -> case content of + CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc + CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta + CIRcvGroupInvitation {} -> showRcvItemProhibited from + CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False + _ -> showRcvItem from + where + from = ttyFromGroup g m + where + quote = maybe [] (groupQuote g) quotedItem + _ -> [] withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of Nothing -> item Just t -> item <> styled (colored Red) (" [" <> t <> "]") @@ -666,15 +667,15 @@ viewItemDelete chat ci@ChatItem {chatDir, meta, content = deletedContent} toItem | timed = [plain ("timed message deleted: " <> T.unpack (ciContentToText deletedContent)) | testView] | byUser = [plain $ "message " <> T.unpack (fromMaybe "deleted" deletedText_)] -- deletedText_ Nothing should be impossible here | otherwise = case chat of - DirectChat c -> case (chatDir, deletedContent) of - (CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c deletedText_) [] mc ts tz meta + DirectChat c -> case (chatDir, deletedContent) of + (CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c deletedText_) [] mc ts tz meta + _ -> prohibited + GroupChat g -> case ciMsgContent deletedContent of + Just mc -> + let m = chatItemMember g ci + in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta + _ -> prohibited _ -> prohibited - GroupChat g -> case ciMsgContent deletedContent of - Just mc -> - let m = chatItemMember g ci - in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta - _ -> prohibited - _ -> prohibited where deletedText_ :: Maybe Text deletedText_ = case toItem of @@ -786,7 +787,9 @@ viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of viewContactsList :: [Contact] -> [StyledString] viewContactsList = - let ldn = T.toLower . (localDisplayName :: Contact -> ContactName) + let getLDN :: Contact -> ContactName + getLDN Contact {localDisplayName} = localDisplayName + ldn = T.toLower . getLDN in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn where muted' Contact {chatSettings, localDisplayName = ldn} @@ -820,8 +823,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] @@ -904,10 +907,10 @@ viewJoinedGroupMember g m = viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString] viewReceivedGroupInvitation g c role = - ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role) : - case incognitoMembershipProfile g of - Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)] - Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"] + ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role) + : case incognitoMembershipProfile g of + Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)] + Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"] groupPreserved :: GroupInfo -> [StyledString] groupPreserved g = ["use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the group"] @@ -993,13 +996,13 @@ viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs GSMemRemoved -> delete "you are removed" GSMemLeft -> delete "you left" GSMemGroupDeleted -> delete "group deleted" - _ -> " (" <> memberCount <> - case enableNtfs of - MFAll -> ")" - MFNone -> ", muted, " <> unmute - MFMentions -> ", mentions only, " <> unmute + _ -> " (" <> memberCount <> viewNtf <> ")" where - unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g) <> ")" + viewNtf = case enableNtfs of + MFAll -> "" + MFNone -> ", muted, " <> unmute + MFMentions -> ", mentions only, " <> unmute + unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g) delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")" memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s" @@ -1025,9 +1028,9 @@ viewContactsMerged c1 c2 ct' = viewContactAndMemberAssociated :: Contact -> GroupInfo -> GroupMember -> Contact -> [StyledString] viewContactAndMemberAssociated ct g m ct' = - [ "contact and member are merged: " <> ttyContact' ct <> ", " <> ttyGroup' g <> " " <> ttyMember m, - "use " <> ttyToContact' ct' <> highlight' "" <> " to send messages" - ] + [ "contact and member are merged: " <> ttyContact' ct <> ", " <> ttyGroup' g <> " " <> ttyMember m, + "use " <> ttyToContact' ct' <> highlight' "" <> " to send messages" + ] viewUserProfile :: Profile -> [StyledString] viewUserProfile Profile {displayName, fullName} = @@ -1393,14 +1396,14 @@ viewContactUpdated Contact {localDisplayName = n', profile = LocalProfile {fullName = fullName', contactLink = contactLink'}} | n == n' && fullName == fullName' && contactLink == contactLink' = [] | n == n' && fullName == fullName' = - if isNothing contactLink' - then [ttyContact n <> " removed contact address"] - else [ttyContact n <> " set new contact address, use " <> highlight ("/info " <> n) <> " to view"] + if isNothing contactLink' + then [ttyContact n <> " removed contact address"] + else [ttyContact n <> " set new contact address, use " <> highlight ("/info " <> n) <> " to view"] | n == n' = ["contact " <> ttyContact n <> fullNameUpdate] | otherwise = - [ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName', - "use " <> ttyToContact n' <> highlight' "" <> " to send messages" - ] + [ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName', + "use " <> ttyToContact n' <> highlight' "" <> " to send messages" + ] where fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName' @@ -1425,11 +1428,11 @@ receivedWithTime_ ts tz from quote CIMeta {itemId, itemTs, itemEdited, itemDelet live | itemEdited || isJust itemDeleted = "" | otherwise = case itemLive of - Just True - | updated -> ttyFrom "[LIVE] " - | otherwise -> ttyFrom "[LIVE started]" <> " use " <> highlight' ("/show [on/off/" <> show itemId <> "] ") - Just False -> ttyFrom "[LIVE ended] " - _ -> "" + Just True + | updated -> ttyFrom "[LIVE] " + | otherwise -> ttyFrom "[LIVE started]" <> " use " <> highlight' ("/show [on/off/" <> show itemId <> "] ") + Just False -> ttyFrom "[LIVE ended] " + _ -> "" ttyMsgTime :: CurrentTime -> TimeZone -> UTCTime -> StyledString ttyMsgTime now tz time = @@ -1455,9 +1458,9 @@ viewSentMessage to quote mc ts tz meta@CIMeta {itemEdited, itemDeleted, itemLive live | itemEdited || isJust itemDeleted = "" | otherwise = case itemLive of - Just True -> ttyTo "[LIVE started] " - Just False -> ttyTo "[LIVE] " - _ -> "" + Just True -> ttyTo "[LIVE started] " + Just False -> ttyTo "[LIVE] " + _ -> "" viewSentBroadcast :: MsgContent -> Int -> Int -> CurrentTime -> TimeZone -> UTCTime -> [StyledString] viewSentBroadcast mc s f ts tz time = prependFirst (highlight' "/feed" <> " (" <> sShow s <> failures <> ") " <> ttyMsgTime ts tz time <> " ") (ttyMsgContent mc) @@ -1548,11 +1551,12 @@ receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIF cfArgsStr (Just cfArgs) = [plain (cryptoFileArgsStr testView cfArgs) | status == "completed"] cfArgsStr _ = [] getRemoteFileStr = case hu of - (Just rhId, Just User {userId}) | status == "completed" -> - [ "File received to connected remote host " <> sShow rhId, - "To download to this device use:", - highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f})) - ] + (Just rhId, Just User {userId}) + | status == "completed" -> + [ "File received to connected remote host " <> sShow rhId, + "To download to this device use:", + highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f})) + ] _ -> [] receivingFile_' _ _ status _ = [plain status <> " receiving file"] -- shouldn't happen @@ -1587,7 +1591,8 @@ viewFileTransferStatus (FTSnd FileTransferMeta {cancelled} fts@(ft : _), chunksN case concatMap recipientsTransferStatus $ groupBy ((==) `on` fs) $ sortOn fs fts of [recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus] recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses - fs = fileStatus :: SndFileTransfer -> FileStatus + fs :: SndFileTransfer -> FileStatus + fs SndFileTransfer {fileStatus} = fileStatus recipientsTransferStatus [] = [] recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts] where @@ -1759,9 +1764,10 @@ viewChatError logLevel testView = \case CEEmptyUserPassword _ -> ["user password is required"] CEUserAlreadyHidden _ -> ["user is already hidden"] CEUserNotHidden _ -> ["user is not hidden"] - CEInvalidDisplayName {displayName, validName} -> map plain $ - ["invalid display name: " <> viewName displayName] - <> ["you could use this one: " <> viewName validName | not (T.null validName)] + CEInvalidDisplayName {displayName, validName} -> + map plain $ + ["invalid display name: " <> viewName displayName] + <> ["you could use this one: " <> viewName validName | not (T.null validName)] CEChatNotStarted -> ["error: chat not started"] CEChatNotStopped -> ["error: chat not stopped"] CEChatStoreChanged -> ["error: chat store changed, please restart chat"] diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 8376a2f56..522f560e5 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module ChatClient where @@ -273,7 +274,7 @@ getTermLine cc = Just s -> do -- remove condition to always echo virtual terminal when (printOutput cc) $ do - -- when True $ do + -- when True $ do name <- userName cc putStrLn $ name <> ": " <> s pure s diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 1a133fd8e..d7c8ff458 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -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 > bob hello" - alice <## " hello too!" - ) + concurrentlyN_ + [ (bob > bob hello" + alice <## " hello too!" + ] bob ##> "/unmute mentions #team" bob <## "ok" alice `send` "> #team @bob (hello) hey bob!" alice <# "#team > bob hello" alice <## " hey bob!" - concurrently_ - ( do bob <# "#team alice> > bob hello" - bob <## " hey bob!" - ) - ( do cath <# "#team alice> > bob hello" - cath <## " hey bob!" - ) + concurrentlyN_ + [ do + bob <# "#team alice> > bob hello" + bob <## " hey bob!", + do + cath <# "#team alice> > bob hello" + cath <## " hey bob!" + ] alice `send` "> #team @cath (hello) hey cath!" alice <# "#team > cath hello too!" alice <## " hey cath!" - concurrently_ - (bob > cath hello too!" - cath <## " hey cath!" - ) + concurrentlyN_ + [ (bob > cath hello too!" + cath <## " hey cath!" + ] bob ##> "/gs" bob <## "#team (3 members, mentions only, you can /unmute #team)" bob ##> "/unmute #team" diff --git a/tests/ChatTests/Files.hs b/tests/ChatTests/Files.hs index db70f9212..4396a900d 100644 --- a/tests/ChatTests/Files.hs +++ b/tests/ChatTests/Files.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PostfixOperators #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module ChatTests.Files where diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 03ddf7d57..868631024 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -7,7 +7,7 @@ import ChatClient import ChatTests.Utils import Control.Concurrent (threadDelay) import Control.Concurrent.Async (concurrently_) -import Control.Monad (when, void) +import Control.Monad (void, when) import qualified Data.ByteString as B import Data.List (isInfixOf) import qualified Data.Text as T @@ -122,7 +122,8 @@ chatGroupTests = do -- because host uses current code and sends version in MemberInfo testNoDirect vrMem2 vrMem3 noConns = it - ( "host " <> vRangeStr supportedChatVRange + ( "host " + <> vRangeStr supportedChatVRange <> (", 2nd mem " <> vRangeStr vrMem2) <> (", 3rd mem " <> vRangeStr vrMem3) <> (if noConns then " : 2 3" else " : 2 <##> 3") @@ -3859,11 +3860,9 @@ testMemberContactProfileUpdate = bob #> "#team hello too" alice <# "#team rob> hello too" cath <# "#team bob> hello too" -- not updated profile - cath #> "#team hello there" alice <# "#team kate> hello there" bob <# "#team cath> hello there" -- not updated profile - bob `send` "@cath hi" bob <### [ "member #team cath does not have direct connection, creating", @@ -3903,7 +3902,6 @@ testMemberContactProfileUpdate = bob #> "#team hello too" alice <# "#team rob> hello too" cath <# "#team rob> hello too" -- updated profile - cath #> "#team hello there" alice <# "#team kate> hello there" bob <# "#team kate> hello there" -- updated profile @@ -3911,7 +3909,7 @@ testMemberContactProfileUpdate = testGroupMsgForward :: HasCallStack => FilePath -> IO () testGroupMsgForward = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> do + \alice bob cath -> do setupGroupForwarding3 "team" alice bob cath bob #> "#team hi there" @@ -3941,7 +3939,6 @@ setupGroupForwarding3 gName alice bob cath = do createGroup3 gName alice bob cath threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected - void $ withCCTransaction bob $ \db -> DB.execute_ db "UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3" void $ withCCTransaction cath $ \db -> @@ -3956,7 +3953,6 @@ testGroupMsgForwardDeduplicate = createGroup3 "team" alice bob cath threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected - void $ withCCTransaction alice $ \db -> DB.execute_ db "UPDATE group_member_intros SET intro_status='fwd'" @@ -3990,7 +3986,7 @@ testGroupMsgForwardDeduplicate = testGroupMsgForwardEdit :: HasCallStack => FilePath -> IO () testGroupMsgForwardEdit = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> do + \alice bob cath -> do setupGroupForwarding3 "team" alice bob cath bob #> "#team hi there" @@ -4001,7 +3997,6 @@ testGroupMsgForwardEdit = bob <# "#team [edited] hello there" alice <# "#team bob> [edited] hello there" cath <# "#team bob> [edited] hello there" -- TODO show as forwarded - alice ##> "/tail #team 1" alice <# "#team bob> hello there" @@ -4014,7 +4009,7 @@ testGroupMsgForwardEdit = testGroupMsgForwardReaction :: HasCallStack => FilePath -> IO () testGroupMsgForwardReaction = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> do + \alice bob cath -> do setupGroupForwarding3 "team" alice bob cath bob #> "#team hi there" @@ -4031,7 +4026,7 @@ testGroupMsgForwardReaction = testGroupMsgForwardDeletion :: HasCallStack => FilePath -> IO () testGroupMsgForwardDeletion = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> do + \alice bob cath -> do setupGroupForwarding3 "team" alice bob cath bob #> "#team hi there" @@ -4073,7 +4068,7 @@ testGroupMsgForwardFile = testGroupMsgForwardChangeRole :: HasCallStack => FilePath -> IO () testGroupMsgForwardChangeRole = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> do + \alice bob cath -> do setupGroupForwarding3 "team" alice bob cath cath ##> "/mr #team bob member" @@ -4084,7 +4079,7 @@ testGroupMsgForwardChangeRole = testGroupMsgForwardNewMember :: HasCallStack => FilePath -> IO () testGroupMsgForwardNewMember = testChat4 aliceProfile bobProfile cathProfile danProfile $ - \alice bob cath dan -> do + \alice bob cath dan -> do setupGroupForwarding3 "team" alice bob cath connectUsers cath dan diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 0a45a74ad..b9a908005 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -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 diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 40fe0e6da..3f89e9b17 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -310,7 +310,7 @@ getInAnyOrder f cc ls = do Predicate p -> p l filterFirst :: (a -> Bool) -> [a] -> [a] filterFirst _ [] = [] - filterFirst p (x:xs) + filterFirst p (x : xs) | p x = xs | otherwise = x : filterFirst p xs @@ -593,7 +593,7 @@ vRangeStr (VersionRange minVer maxVer) = "(" <> show minVer <> ", " <> show maxV linkAnotherSchema :: String -> String linkAnotherSchema link | "https://simplex.chat/" `isPrefixOf` link = - T.unpack $ T.replace "https://simplex.chat/" "simplex:/" $ T.pack link + T.unpack $ T.replace "https://simplex.chat/" "simplex:/" $ T.pack link | "simplex:/" `isPrefixOf` link = - T.unpack $ T.replace "simplex:/" "https://simplex.chat/" $ T.pack link + T.unpack $ T.replace "simplex:/" "https://simplex.chat/" $ T.pack link | otherwise = error "link starts with neither https://simplex.chat/ nor simplex:/" diff --git a/tests/Test.hs b/tests/Test.hs index 568f9688d..ee5804aa9 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -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 ()