diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 62d3c36a3..5e30da67e 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -11,7 +11,7 @@ on: jobs: build: - name: build-${{ matrix.os }} + name: build-${{ matrix.os }}-${{ matrix.ghc }} runs-on: ${{ matrix.os }} strategy: fail-fast: false @@ -19,8 +19,13 @@ jobs: include: - os: ubuntu-20.04 platform_name: 20_04-x86-64 + ghc: "8.10.7" + - os: ubuntu-20.04 + platform_name: 20_04-x86-64 + ghc: "9.6.3" - os: ubuntu-22.04 platform_name: 22_04-x86-64 + ghc: "9.6.3" steps: - name: Clone project uses: actions/checkout@v3 @@ -28,7 +33,7 @@ jobs: - name: Setup Haskell uses: haskell-actions/setup@v2 with: - ghc-version: "9.6.3" + ghc-version: ${{ matrix.ghc }} cabal-version: "3.10.1.0" - name: Cache dependencies diff --git a/package.yaml b/package.yaml index da75e6314..14b9568ea 100644 --- a/package.yaml +++ b/package.yaml @@ -62,7 +62,7 @@ dependencies: - socks == 0.6.* - sqlcipher-simple == 0.4.* - stm == 2.5.* - - template-haskell == 2.20.* + - template-haskell >= 2.16 && < 2.21 - temporary == 1.3.* - text == 2.0.* - time == 1.9.* diff --git a/simplexmq.cabal b/simplexmq.cabal index effc9c530..b951d838d 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -204,7 +204,7 @@ library , socks ==0.6.* , sqlcipher-simple ==0.4.* , stm ==2.5.* - , template-haskell ==2.20.* + , template-haskell >=2.16 && <2.21 , temporary ==1.3.* , text ==2.0.* , time ==1.9.* @@ -270,7 +270,7 @@ executable ntf-server , socks ==0.6.* , sqlcipher-simple ==0.4.* , stm ==2.5.* - , template-haskell ==2.20.* + , template-haskell >=2.16 && <2.21 , temporary ==1.3.* , text ==2.0.* , time ==1.9.* @@ -336,7 +336,7 @@ executable smp-agent , socks ==0.6.* , sqlcipher-simple ==0.4.* , stm ==2.5.* - , template-haskell ==2.20.* + , template-haskell >=2.16 && <2.21 , temporary ==1.3.* , text ==2.0.* , time ==1.9.* @@ -402,7 +402,7 @@ executable smp-server , socks ==0.6.* , sqlcipher-simple ==0.4.* , stm ==2.5.* - , template-haskell ==2.20.* + , template-haskell >=2.16 && <2.21 , temporary ==1.3.* , text ==2.0.* , time ==1.9.* @@ -468,7 +468,7 @@ executable xftp , socks ==0.6.* , sqlcipher-simple ==0.4.* , stm ==2.5.* - , template-haskell ==2.20.* + , template-haskell >=2.16 && <2.21 , temporary ==1.3.* , text ==2.0.* , time ==1.9.* @@ -534,7 +534,7 @@ executable xftp-server , socks ==0.6.* , sqlcipher-simple ==0.4.* , stm ==2.5.* - , template-haskell ==2.20.* + , template-haskell >=2.16 && <2.21 , temporary ==1.3.* , text ==2.0.* , time ==1.9.* @@ -637,7 +637,7 @@ test-suite simplexmq-test , socks ==0.6.* , sqlcipher-simple ==0.4.* , stm ==2.5.* - , template-haskell ==2.20.* + , template-haskell >=2.16 && <2.21 , temporary ==1.3.* , text ==2.0.* , time ==1.9.* diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index fc484f7e5..f558b652f 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -485,7 +484,7 @@ runXFTPSndWorker c srv doWork = do rcvChunks :: [[FileChunk]] rcvChunks = map (sortChunks . M.elems) $ M.elems $ foldl' addRcvChunk M.empty rcvReplicas sortChunks :: [FileChunk] -> [FileChunk] - sortChunks = map reverseReplicas . sortOn (\fc -> fc.chunkNo) + sortChunks = map reverseReplicas . sortOn (\FileChunk {chunkNo} -> chunkNo) reverseReplicas ch@FileChunk {replicas} = (ch :: FileChunk) {replicas = reverse replicas} addRcvChunk :: Map Int (Map Int FileChunk) -> SentRecipientReplica -> Map Int (Map Int FileChunk) addRcvChunk m SentRecipientReplica {chunkNo, server, rcvNo, replicaId, replicaKey, digest, chunkSize} = diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 04e6ff429..240eb57af 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -3,7 +3,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -111,7 +110,7 @@ xftpClientServer = B.unpack . strEncode . snd3 . transportSession snd3 (_, s, _) = s xftpTransportHost :: XFTPClient -> TransportHost -xftpTransportHost c = c.http2Client.client_.host +xftpTransportHost XFTPClient {http2Client = HTTP2Client {client_ = HClient {host}}} = host xftpSessionTs :: XFTPClient -> UTCTime xftpSessionTs = sessionTs . http2Client diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index 08e03a556..0ed2a54f9 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -5,7 +5,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -361,7 +360,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re rcvChunks :: [[FileChunk]] rcvChunks = map (sortChunks . M.elems) $ M.elems $ foldl' addRcvChunk M.empty rcvReplicas sortChunks :: [FileChunk] -> [FileChunk] - sortChunks = map reverseReplicas . sortOn (\c -> c.chunkNo) + sortChunks = map reverseReplicas . sortOn (\FileChunk {chunkNo} -> chunkNo) reverseReplicas ch@FileChunk {replicas} = (ch :: FileChunk) {replicas = reverse replicas} addRcvChunk :: Map Int (Map Int FileChunk) -> SentRecipientReplica -> Map Int (Map Int FileChunk) addRcvChunk m SentRecipientReplica {chunkNo, server, rcvNo, replicaId, replicaKey, digest, chunkSize} = @@ -420,7 +419,9 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig liftIO $ printNoNewLine "Downloading file..." downloadedChunks <- newTVarIO [] - let srv FileChunk {replicas} = (head replicas).server + let srv FileChunk {replicas} = case replicas of + [] -> error "empty FileChunk.replicas" + FileChunkReplica {server} : _ -> server srvChunks = groupAllOn srv chunks chunkPaths <- map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 srvChunks (mapM $ downloadFileChunk a encPath size downloadedChunks) encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths @@ -498,10 +499,9 @@ cliFileDescrInfo InfoOptions {fileDescription} = do printParty putStrLn $ "File download size: " <> strEnc size putStrLn "File server(s):" - forM_ replicas $ \srvReplicas -> do - let srv = (head srvReplicas).server - chSizes = map (\FileServerReplica {chunkSize = chSize_} -> unFileSize $ fromMaybe chunkSize chSize_) srvReplicas - putStrLn $ strEnc srv <> ": " <> strEnc (FileSize $ sum chSizes) + forM_ replicas $ \srvReplicas@(FileServerReplica {server} :| _) -> do + let chSizes = fmap (\FileServerReplica {chunkSize = chSize_} -> unFileSize $ fromMaybe chunkSize chSize_) srvReplicas + putStrLn $ strEnc server <> ": " <> strEnc (FileSize $ sum chSizes) where printParty :: IO () printParty = case party of diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs index 64a1d8a32..cbea3f23b 100644 --- a/src/Simplex/FileTransfer/Description.hs +++ b/src/Simplex/FileTransfer/Description.hs @@ -4,7 +4,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -45,6 +44,8 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Int (Int64) import Data.List (foldl', sortOn) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as L import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe) @@ -59,7 +60,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, parseAll) import Simplex.Messaging.Protocol (XFTPServer) -import Simplex.Messaging.Util (bshow, groupAllOn, (<$?>)) +import Simplex.Messaging.Util (bshow, (<$?>)) data FileDescription (p :: FileParty) = FileDescription { party :: SFileParty p, @@ -199,7 +200,7 @@ validateFileDescription fd@FileDescription {size, chunks} | chunksSize chunks /= unFileSize size = Left "chunks total size is different than file size" | otherwise = Right $ ValidFD fd where - chunkNos = map (\c -> c.chunkNo) chunks + chunkNos = map (\FileChunk {chunkNo} -> chunkNo) chunks chunksSize = fromIntegral . foldl' (\s FileChunk {chunkSize} -> s + unFileSize chunkSize) 0 encodeFileDescription :: FileDescription p -> YAMLFileDescription @@ -240,18 +241,18 @@ instance FromField a => FromField (FileSize a) where fromField f = FileSize <$> instance ToField a => ToField (FileSize a) where toField (FileSize s) = toField s -groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [[FileServerReplica]] +groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [NonEmpty FileServerReplica] groupReplicasByServer defChunkSize = - groupAllOn (\r -> r.server) . unfoldChunksToReplicas defChunkSize + L.groupAllWith (\FileServerReplica {server} -> server) . unfoldChunksToReplicas defChunkSize encodeFileReplicas :: FileSize Word32 -> [FileChunk] -> [YAMLServerReplicas] encodeFileReplicas defChunkSize = map encodeServerReplicas . groupReplicasByServer defChunkSize where - encodeServerReplicas fs = + encodeServerReplicas fs@(FileServerReplica {server} :| _) = YAMLServerReplicas - { server = (head fs).server, -- groupAllOn guarantees that fs is not empty - chunks = map (B.unpack . encodeServerReplica) fs + { server, + chunks = map (B.unpack . encodeServerReplica) $ L.toList fs } encodeServerReplica :: FileServerReplica -> ByteString @@ -305,7 +306,7 @@ foldReplicasToChunks :: FileSize Word32 -> [FileServerReplica] -> Either String foldReplicasToChunks defChunkSize fs = do sd <- foldSizesDigests fs -- TODO validate (check that chunks match) or in separate function - sortOn (\c -> c.chunkNo) . map reverseReplicas . M.elems <$> foldChunks sd fs + sortOn (\FileChunk {chunkNo} -> chunkNo) . map reverseReplicas . M.elems <$> foldChunks sd fs where foldSizesDigests :: [FileServerReplica] -> Either String (Map Int (FileSize Word32), Map Int FileDigest) foldSizesDigests = foldl' addSizeDigest $ Right (M.empty, M.empty) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index ae4819762..10cc644ed 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -8,7 +8,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -986,7 +985,7 @@ runCommandProcessing c@AgentClient {subQ} server_ = do withServer $ \srv -> tryWithLock "ICQSecure" . withDuplexConn $ \(DuplexConnection cData rqs sqs) -> case find (sameQueue (srv, rId)) rqs of Just rq'@RcvQueue {server, sndId, status, dbReplaceQueueId = Just replaceQId} -> - case find (\q -> replaceQId == q.dbQueueId) rqs of + case find ((replaceQId ==) . dbQId) rqs of Just rq1 -> when (status == Confirmed) $ do secureQueue c rq' senderKey withStore' c $ \db -> setRcvQueueStatus db rq' Secured @@ -1243,7 +1242,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl -- this is the same queue where this loop delivers messages to but with updated state Just SndQueue {dbReplaceQueueId = Just replacedId, primary} -> -- second part of this condition is a sanity check because dbReplaceQueueId cannot point to the same queue, see switchConnection' - case removeQP (\sq' -> sq'.dbQueueId == replacedId && not (sameQueue addr sq')) sqs of + case removeQP (\sq' -> dbQId sq' == replacedId && not (sameQueue addr sq')) sqs of Nothing -> internalErr msgId "sent QTEST: queue not found in connection" Just (sq', sq'' : sqs') -> do checkSQSwchStatus sq' SSSendingQTEST @@ -1358,7 +1357,7 @@ abortConnectionSwitch' c connId = | canAbortRcvSwitch rq -> do when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED -- multiple queues to which the connections switches were possible when repeating switch was allowed - let (delRqs, keepRqs) = L.partition (\q -> Just rq.dbQueueId == q.dbReplaceQueueId) rqs + let (delRqs, keepRqs) = L.partition ((Just (dbQId rq) ==) . dbReplaceQId) rqs case L.nonEmpty keepRqs of Just rqs' -> do rq' <- withStore' c $ \db -> do @@ -1476,7 +1475,7 @@ deleteConnQueues c ntf rqs = do | temporaryOrHostError e && deleteErrors rq + 1 < maxErrs -> withStore' c (`incRcvDeleteErrors` rq) $> r | otherwise -> withStore' c (`deleteConnRcvQueue` rq) >> notifyRQ rq (Just e) $> Right () pure (rq, r') - notifyRQ rq e_ = notify ("", rq.connId, APC SAEConn $ DEL_RCVQ (qServer rq) (queueId rq) e_) + notifyRQ rq e_ = notify ("", qConnId rq, APC SAEConn $ DEL_RCVQ (qServer rq) (queueId rq) e_) notify = when ntf . atomically . writeTBQueue (subQ c) connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ()) connResults = M.map snd . foldl' addResult M.empty @@ -1922,7 +1921,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s case (conn', dbReplaceQueueId) of (DuplexConnection _ rqs _, Just replacedId) -> do when primary . withStore' c $ \db -> setRcvQueuePrimary db connId rq - case find (\q -> replacedId == q.dbQueueId) rqs of + case find ((replacedId ==) . dbQId) rqs of Just rq'@RcvQueue {server, rcvId} -> do checkRQSwchStatus rq' RSSendingQUSE void $ withStore' c $ \db -> setRcvSwitchStatus db rq' $ Just RSReceivedMessage @@ -2197,7 +2196,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s case (findQ (qAddress sqInfo) sqs, findQ addr sqs) of (Just _, _) -> qError "QADD: queue address is already used in connection" (_, Just sq@SndQueue {dbQueueId}) -> do - let (delSqs, keepSqs) = L.partition (\q -> Just dbQueueId == q.dbReplaceQueueId) sqs + let (delSqs, keepSqs) = L.partition ((Just dbQueueId == ) . dbReplaceQId) sqs case L.nonEmpty keepSqs of Just sqs' -> do -- move inside case? @@ -2248,7 +2247,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s when (ratchetSyncSendProhibited cData') $ throwError $ AGENT (A_QUEUE "ratchet is not synchronized") case findQ addr sqs of Just sq'@SndQueue {dbReplaceQueueId = Just replaceQId} -> do - case find (\q -> replaceQId == q.dbQueueId) sqs of + case find ((replaceQId ==) . dbQId) sqs of Just sq1 -> do checkSQSwchStatus sq1 SSSendingQKEY logServer "<--" c srv rId $ "MSG " <> logSecret (snd addr) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index a2180a337..00a7407be 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -10,7 +10,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -444,7 +443,7 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, TM.delete tSess smpClients qs <- RQ.getDelSessQueues tSess $ activeSubs c mapM_ (`RQ.addQueue` pendingSubs c) qs - let cs = S.fromList $ map (\q -> q.connId) qs + let cs = S.fromList $ map qConnId qs cs' <- RQ.getConns $ activeSubs c pure (qs, S.toList $ cs `S.difference` cs') @@ -827,7 +826,7 @@ mkSMPTransportSession :: (AgentMonad' m, SMPQueueRec q) => AgentClient -> q -> m mkSMPTransportSession c q = mkSMPTSession q <$> getSessionMode c mkSMPTSession :: SMPQueueRec q => q -> TransportSessionMode -> SMPTransportSession -mkSMPTSession q = mkTSession q.userId (qServer q) q.connId +mkSMPTSession q = mkTSession (qUserId q) (qServer q) (qConnId q) getSessionMode :: AgentMonad' m => AgentClient -> m TransportSessionMode getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 27b193693..6296fc350 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -8,7 +8,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -27,7 +26,6 @@ import qualified Data.List.NonEmpty as L import Data.Maybe (isJust) import Data.Time (UTCTime) import Data.Type.Equality -import GHC.Records (HasField) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval (RI2State) import qualified Simplex.Messaging.Crypto as C @@ -182,16 +180,34 @@ switchingRQ = find $ isJust . rcvSwchStatus {-# INLINE switchingRQ #-} updatedQs :: SMPQueueRec q => q -> NonEmpty q -> NonEmpty q -updatedQs q = L.map $ \q' -> if q.dbQueueId == q'.dbQueueId then q else q' +updatedQs q = L.map $ \q' -> if dbQId q == dbQId q' then q else q' {-# INLINE updatedQs #-} -type SMPQueueRec q = - ( SMPQueue q, - HasField "userId" q UserId, - HasField "connId" q ConnId, - HasField "dbQueueId" q Int64, - HasField "dbReplaceQueueId" q (Maybe Int64) - ) +class SMPQueue q => SMPQueueRec q where + qUserId :: q -> UserId + qConnId :: q -> ConnId + dbQId :: q -> Int64 + dbReplaceQId :: q -> Maybe Int64 + +instance SMPQueueRec RcvQueue where + qUserId RcvQueue {userId} = userId + {-# INLINE qUserId #-} + qConnId RcvQueue {connId} = connId + {-# INLINE qConnId #-} + dbQId RcvQueue {dbQueueId} = dbQueueId + {-# INLINE dbQId #-} + dbReplaceQId RcvQueue {dbReplaceQueueId} = dbReplaceQueueId + {-# INLINE dbReplaceQId #-} + +instance SMPQueueRec SndQueue where + qUserId SndQueue {userId} = userId + {-# INLINE qUserId #-} + qConnId SndQueue {connId} = connId + {-# INLINE qConnId #-} + dbQId SndQueue {dbQueueId} = dbQueueId + {-# INLINE dbQId #-} + dbReplaceQId SndQueue {dbReplaceQueueId} = dbReplaceQueueId + {-# INLINE dbReplaceQId #-} -- * Connection types diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 72d4c261a..e37cd2167 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -10,7 +10,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE QuasiQuotes #-} @@ -1972,7 +1971,7 @@ insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, interna DB.execute db "INSERT INTO encrypted_rcv_message_hashes (conn_id, hash) VALUES (?,?)" (connId, encryptedMsgHash) updateHashRcv_ :: DB.Connection -> ConnId -> RcvMsgData -> IO () -updateHashRcv_ dbConn connId RcvMsgData {msgMeta, internalHash, internalRcvId} = +updateHashRcv_ dbConn connId RcvMsgData {msgMeta = MsgMeta {sndMsgId}, internalHash, internalRcvId} = DB.executeNamed dbConn -- last_internal_rcv_msg_id equality check prevents race condition in case next id was reserved @@ -1983,7 +1982,7 @@ updateHashRcv_ dbConn connId RcvMsgData {msgMeta, internalHash, internalRcvId} = WHERE conn_id = :conn_id AND last_internal_rcv_msg_id = :last_internal_rcv_msg_id; |] - [ ":last_external_snd_msg_id" := msgMeta.sndMsgId, + [ ":last_external_snd_msg_id" := sndMsgId, ":last_rcv_msg_hash" := internalHash, ":conn_id" := connId, ":last_internal_rcv_msg_id" := internalRcvId diff --git a/src/Simplex/Messaging/Notifications/Server/Stats.hs b/src/Simplex/Messaging/Notifications/Server/Stats.hs index 24c6d522b..7debc1ac9 100644 --- a/src/Simplex/Messaging/Notifications/Server/Stats.hs +++ b/src/Simplex/Messaging/Notifications/Server/Stats.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} module Simplex.Messaging.Notifications.Server.Stats where @@ -56,31 +55,31 @@ newNtfServerStats ts = do pure NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} getNtfServerStatsData :: NtfServerStats -> STM NtfServerStatsData -getNtfServerStatsData s = do - _fromTime <- readTVar s.fromTime - _tknCreated <- readTVar s.tknCreated - _tknVerified <- readTVar s.tknVerified - _tknDeleted <- readTVar s.tknDeleted - _subCreated <- readTVar s.subCreated - _subDeleted <- readTVar s.subDeleted - _ntfReceived <- readTVar s.ntfReceived - _ntfDelivered <- readTVar s.ntfDelivered - _activeTokens <- getPeriodStatsData s.activeTokens - _activeSubs <- getPeriodStatsData s.activeSubs +getNtfServerStatsData s@NtfServerStats {fromTime} = do + _fromTime <- readTVar fromTime + _tknCreated <- readTVar $ tknCreated s + _tknVerified <- readTVar $ tknVerified s + _tknDeleted <- readTVar $ tknDeleted s + _subCreated <- readTVar $ subCreated s + _subDeleted <- readTVar $ subDeleted s + _ntfReceived <- readTVar $ ntfReceived s + _ntfDelivered <- readTVar $ ntfDelivered s + _activeTokens <- getPeriodStatsData $ activeTokens s + _activeSubs <- getPeriodStatsData $ activeSubs s pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs} setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> STM () -setNtfServerStats s d = do - writeTVar s.fromTime $! d._fromTime - writeTVar s.tknCreated $! _tknCreated d - writeTVar s.tknVerified $! _tknVerified d - writeTVar s.tknDeleted $! _tknDeleted d - writeTVar s.subCreated $! _subCreated d - writeTVar s.subDeleted $! _subDeleted d - writeTVar s.ntfReceived $! _ntfReceived d - writeTVar s.ntfDelivered $! _ntfDelivered d - setPeriodStats s.activeTokens (_activeTokens d) - setPeriodStats s.activeSubs (_activeSubs d) +setNtfServerStats s@NtfServerStats {fromTime} d@NtfServerStatsData {_fromTime} = do + writeTVar fromTime $! _fromTime + writeTVar (tknCreated s) $! _tknCreated d + writeTVar (tknVerified s) $! _tknVerified d + writeTVar (tknDeleted s) $! _tknDeleted d + writeTVar (subCreated s) $! _subCreated d + writeTVar (subDeleted s) $! _subDeleted d + writeTVar (ntfReceived s) $! _ntfReceived d + writeTVar (ntfDelivered s) $! _ntfDelivered d + setPeriodStats (activeTokens s) (_activeTokens d) + setPeriodStats (activeSubs s) (_activeSubs d) instance StrEncoding NtfServerStatsData where strEncode NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs} = diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index c130d117e..0563cfeb5 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -118,6 +118,8 @@ module Simplex.Messaging.Protocol userProtocol, rcvMessageMeta, noMsgFlags, + messageId, + messageTs, -- * Parse and serialize ProtocolMsgTag (..), @@ -356,6 +358,16 @@ data Message msgTs :: SystemTime } +messageId :: Message -> MsgId +messageId = \case + Message {msgId} -> msgId + MessageQuota {msgId} -> msgId + +messageTs :: Message -> SystemTime +messageTs = \case + Message {msgTs} -> msgTs + MessageQuota {msgTs} -> msgTs + instance StrEncoding RcvMessage where strEncode RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} = B.unwords diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 326ad0d8e..edbbe667e 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -7,7 +8,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -49,18 +49,16 @@ import qualified Data.ByteString.Char8 as B import Data.Either (fromRight, partitionEithers) import Data.Functor (($>)) import Data.Int (Int64) -import Data.List (intercalate, sort) +import Data.List (intercalate) import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (isNothing) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) import Data.Type.Equality -import GHC.Conc (listThreads, threadStatus) -import GHC.Conc.Sync (threadLabel) import GHC.Stats (getRTSStats) import GHC.TypeLits (KnownNat) import Network.Socket (ServiceName, Socket, socketToHandle) @@ -92,6 +90,12 @@ import UnliftIO.Directory (doesFileExist, renameFile) import UnliftIO.Exception import UnliftIO.IO import UnliftIO.STM +#if MIN_VERSION_base(4,18,0) +import Data.List (sort) +import Data.Maybe (fromMaybe) +import GHC.Conc (listThreads, threadStatus) +import GHC.Conc.Sync (threadLabel) +#endif -- | Runs an SMP server using passed configuration. -- @@ -297,12 +301,16 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do putStat label var = readTVarIO var >>= \v -> hPutStrLn h $ label <> ": " <> show v CPStatsRTS -> getRTSStats >>= hPutStrLn h . show CPThreads -> do +#if MIN_VERSION_base(4,18,0) threads <- liftIO listThreads hPutStrLn h $ "Threads: " <> show (length threads) forM_ (sort threads) $ \tid -> do label <- threadLabel tid status <- threadStatus tid hPutStrLn h $ show tid <> " (" <> show status <> ") " <> fromMaybe "" label +#else + hPutStrLn h "Not available on GHC 8.10" +#endif CPSave -> withLock (savingLock srv) "control" $ do hPutStrLn h "saving server state..." unliftIO u $ saveServer True @@ -318,7 +326,7 @@ runClientTransport th@THandle {thVersion, sessionId} = do c <- atomically $ newClient q thVersion sessionId ts s <- asks server expCfg <- asks $ inactiveClientExpiration . config - labelMyThread . B.unpack $ "client $" <> encode c.sessionId + labelMyThread . B.unpack $ "client $" <> encode sessionId raceAny_ ([liftIO $ send th c, client c s, receive th c] <> disconnectThread_ c expCfg) `finally` clientDisconnected c where @@ -441,8 +449,8 @@ dummyKeyEd448 :: C.PublicKey 'C.Ed448 dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA" client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m () -client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} = do - labelMyThread . B.unpack $ "client $" <> encode clnt.sessionId <> " commands" +client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Server {subscribedQ, ntfSubscribedQ, notifiers} = do + labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands" forever $ atomically (readTBQueue rcvQ) >>= mapM processCommand @@ -763,11 +771,11 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv encrypt msgFlags body = let encBody = EncRcvMsgBody $ C.cbEncryptMaxLenBS (rcvDhSecret qr) (C.cbNonce msgId') body in RcvMessage msgId' msgTs' msgFlags encBody - msgId' = msg.msgId - msgTs' = msg.msgTs + msgId' = messageId msg + msgTs' = messageTs msg setDelivered :: Sub -> Message -> STM Bool - setDelivered s msg = tryPutTMVar (delivered s) msg.msgId + setDelivered s msg = tryPutTMVar (delivered s) (messageId msg) getStoreMsgQueue :: T.Text -> RecipientId -> m MsgQueue getStoreMsgQueue name rId = time (name <> " getMsgQueue") $ do @@ -867,7 +875,7 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages | maybe True (systemSeconds msgTs >=) old_ -> isNothing <$> writeMsg q msg | otherwise -> pure False MessageQuota {} -> writeMsg q msg $> False - when logFull . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode msg.msgId + when logFull . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg) updateMsgV1toV3 QueueRec {rcvDhSecret} RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} = do let nonce = C.cbNonce msgId msgBody <- liftEither . first (msgErr "v1 message decryption") $ C.maxLenBS =<< C.cbDecrypt rcvDhSecret nonce body diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index 9d525c344..fb78033e6 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -3,7 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} @@ -162,7 +161,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct case chain of [_leaf, ca] -> do let kh = certFingerprint ca - accept = maybe True (\h -> h.hostFingerprint == kh) knownHost_ + accept = maybe True (\h -> hostFingerprint h == kh) knownHost_ if accept then atomically (putTMVar hostCAHash kh) $> TLS.CertificateUsageAccept else pure $ TLS.CertificateUsageReject TLS.CertificateRejectUnknownCA @@ -234,7 +233,7 @@ prepareHostSession updateKnownHost :: C.KeyHash -> C.PublicKeyX25519 -> ExceptT RCErrorType IO KnownHostPairing updateKnownHost ca hostDhPubKey = case knownHost_ of Just h -> do - unless (h.hostFingerprint == tlsHostFingerprint) . throwError $ + unless (hostFingerprint h == tlsHostFingerprint) . throwError $ RCEInternal "TLS host CA is different from host pairing, should be caught in TLS handshake" pure (h :: KnownHostPairing) {hostDhPubKey} Nothing -> pure KnownHostPairing {hostFingerprint = ca, hostDhPubKey} diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 15a42fa8c..49b68a57c 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -6,7 +6,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -135,8 +134,8 @@ ntfServerTest :: ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h where tPut' :: THandle c -> (Maybe C.ASignature, ByteString, ByteString, smp) -> IO () - tPut' h (sig, corrId, queueId, smp) = do - let t' = smpEncode (h.sessionId, corrId, queueId, smp) + tPut' h@THandle {sessionId} (sig, corrId, queueId, smp) = do + let t' = smpEncode (sessionId, corrId, queueId, smp) [Right ()] <- tPut h Nothing [(sig, t')] pure () tGet' h = do diff --git a/tests/RemoteControl.hs b/tests/RemoteControl.hs index ffea63785..d4079fe9f 100644 --- a/tests/RemoteControl.hs +++ b/tests/RemoteControl.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} module RemoteControl where @@ -11,6 +10,7 @@ import Crypto.Random (ChaChaDRG, drgNew) import qualified Data.Aeson as J import Data.List.NonEmpty (NonEmpty (..)) import Simplex.Messaging.Encoding.String (StrEncoding (..)) +import qualified Simplex.RemoteControl.Client as HC (RCHostClient (action)) import qualified Simplex.RemoteControl.Client as RC import Simplex.RemoteControl.Discovery (mkLastLocalHost, preferAddress) import Simplex.RemoteControl.Invitation (RCSignedInvitation, verifySignedInvitation) @@ -32,33 +32,33 @@ testPreferAddress :: Spec testPreferAddress = do it "suppresses localhost" $ mkLastLocalHost addrs - `shouldBe` [ "10.20.30.40" @ "eth0", - "10.20.30.42" @ "wlan0", - "127.0.0.1" @ "lo" + `shouldBe` [ "10.20.30.40" `on` "eth0", + "10.20.30.42" `on` "wlan0", + "127.0.0.1" `on` "lo" ] it "finds by address" $ do - preferAddress ("127.0.0.1" @ "lo23") addrs' `shouldBe` addrs -- localhost is back on top - preferAddress ("10.20.30.42" @ "wlp2s0") addrs' - `shouldBe` [ "10.20.30.42" @ "wlan0", - "10.20.30.40" @ "eth0", - "127.0.0.1" @ "lo" + preferAddress ("127.0.0.1" `on` "lo23") addrs' `shouldBe` addrs -- localhost is back on top + preferAddress ("10.20.30.42" `on` "wlp2s0") addrs' + `shouldBe` [ "10.20.30.42" `on` "wlan0", + "10.20.30.40" `on` "eth0", + "127.0.0.1" `on` "lo" ] it "finds by interface" $ do - preferAddress ("127.1.2.3" @ "lo") addrs' `shouldBe` addrs - preferAddress ("0.0.0.0" @ "eth0") addrs' `shouldBe` addrs' + preferAddress ("127.1.2.3" `on` "lo") addrs' `shouldBe` addrs + preferAddress ("0.0.0.0" `on` "eth0") addrs' `shouldBe` addrs' it "survives duplicates" $ do - preferAddress ("0.0.0.0" @ "eth1") addrsDups `shouldBe` addrsDups - preferAddress ("0.0.0.0" @ "eth0") ifaceDups `shouldBe` ifaceDups + preferAddress ("0.0.0.0" `on` "eth1") addrsDups `shouldBe` addrsDups + preferAddress ("0.0.0.0" `on` "eth0") ifaceDups `shouldBe` ifaceDups where - th @ interface = RCCtrlAddress {address = either error id $ strDecode th, interface} + on th interface = RCCtrlAddress {address = either error id $ strDecode th, interface} addrs = - [ "127.0.0.1" @ "lo", -- localhost may go first and break things - "10.20.30.40" @ "eth0", - "10.20.30.42" @ "wlan0" + [ "127.0.0.1" `on` "lo", -- localhost may go first and break things + "10.20.30.40" `on` "eth0", + "10.20.30.42" `on` "wlan0" ] addrs' = mkLastLocalHost addrs - addrsDups = "10.20.30.40" @ "eth1" : addrs' - ifaceDups = "10.20.30.41" @ "eth0" : addrs' + addrsDups = "10.20.30.40" `on` "eth1" : addrs' + ifaceDups = "10.20.30.41" `on` "eth0" : addrs' testNewPairing :: IO () testNewPairing = do @@ -98,7 +98,7 @@ testNewPairing = do logNote "ctrl: adios" pure sessId' - waitCatch hc.action >>= \case + waitCatch (HC.action hc) >>= \case Left err -> fromException err `shouldBe` Just AsyncCancelled Right () -> fail "Unexpected controller finish" diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index c5f45e003..4aa42e3f9 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -2,9 +2,9 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -161,8 +161,8 @@ smpServerTest :: smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h where tPut' :: THandle c -> (Maybe C.ASignature, ByteString, ByteString, smp) -> IO () - tPut' h (sig, corrId, queueId, smp) = do - let t' = smpEncode (h.sessionId, corrId, queueId, smp) + tPut' h@THandle {sessionId} (sig, corrId, queueId, smp) = do + let t' = smpEncode (sessionId, corrId, queueId, smp) [Right ()] <- tPut h Nothing [(sig, t')] pure () tGet' h = do