5.4.0.0: use ghc 9.6.2 (#791)

* Add 9.6 compat

* compile with GHC9.6.2: dependencies, imports, code

* refactor typeclasses

* refactor record dot

* update cabal version

* update github actions

* update direct-sqlcipher

* 5.4.0.0

* update cabal.project

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>

src/Simplex/FileTransfer/Agent.hs

@@ -4,12 +4,15 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
+
 module Simplex.FileTransfer.Agent
   ( startXFTPWorkers,
     closeXFTPAgent,
@@ -24,7 +27,6 @@ module Simplex.FileTransfer.Agent
   )
 where
 
-import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple (logError)
 import Control.Monad
 import Control.Monad.Except
@@ -480,7 +482,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 (chunkNo :: FileChunk -> Int)
+            sortChunks = map reverseReplicas . sortOn (\fc -> fc.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} =

src/Simplex/FileTransfer/Client.hs

@@ -3,12 +3,14 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Simplex.FileTransfer.Client where
 
+import Control.Monad
 import Control.Monad.Except
 import Data.Bifunctor (first)
 import Data.ByteString.Builder (Builder, byteString)
@@ -108,7 +110,7 @@ xftpClientServer = B.unpack . strEncode . snd3 . transportSession
     snd3 (_, s, _) = s
 
 xftpTransportHost :: XFTPClient -> TransportHost
-xftpTransportHost = (host :: HClient -> TransportHost) . client_ . http2Client
+xftpTransportHost c = c.http2Client.client_.host
 
 xftpSessionTs :: XFTPClient -> UTCTime
 xftpSessionTs = sessionTs . http2Client

src/Simplex/FileTransfer/Client/Agent.hs

@@ -8,6 +8,7 @@
 module Simplex.FileTransfer.Client.Agent where
 
 import Control.Logger.Simple (logInfo)
+import Control.Monad
 import Control.Monad.Except
 import Data.Bifunctor (first)
 import qualified Data.ByteString.Char8 as B
@@ -21,7 +22,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (catchAll_, tryError)
+import Simplex.Messaging.Util (catchAll_)
 import UnliftIO
 
 type XFTPClientVar = TMVar (Either XFTPClientAgentError XFTPClient)

src/Simplex/FileTransfer/Client/Main.hs

@@ -5,10 +5,13 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
+
 module Simplex.FileTransfer.Client.Main
   ( SendOptions (..),
     CLIError (..),
@@ -27,7 +30,6 @@ module Simplex.FileTransfer.Client.Main
   )
 where
 
-import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
@@ -367,7 +369,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 (chunkNo :: FileChunk -> Int)
+        sortChunks = map reverseReplicas . sortOn (\c -> c.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} =
@@ -426,7 +428,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
       a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
       liftIO $ printNoNewLine "Downloading file..."
       downloadedChunks <- newTVarIO []
-      let srv FileChunk {replicas} = server (head replicas :: FileChunkReplica)
+      let srv FileChunk {replicas} = (head replicas).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
@@ -505,7 +507,7 @@ cliFileDescrInfo InfoOptions {fileDescription} = do
         putStrLn $ "File download size: " <> strEnc size
         putStrLn "File server(s):"
         forM_ replicas $ \srvReplicas -> do
-          let srv = replicaServer $ head srvReplicas
+          let srv = (head srvReplicas).server
               chSizes = map (\FileServerReplica {chunkSize = chSize_} -> unFileSize $ fromMaybe chunkSize chSize_) srvReplicas
           putStrLn $ strEnc srv <> ": " <> strEnc (FileSize $ sum chSizes)
       where

src/Simplex/FileTransfer/Crypto.hs

@@ -6,6 +6,7 @@
 
 module Simplex.FileTransfer.Crypto where
 
+import Control.Monad
 import Control.Monad.Except
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)

src/Simplex/FileTransfer/Description.hs

@@ -5,10 +5,13 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
+
 module Simplex.FileTransfer.Description
   ( FileDescription (..),
     AFileDescription (..),
@@ -25,7 +28,6 @@ module Simplex.FileTransfer.Description
     YAMLServerReplicas (..), -- for tests
     validateFileDescription,
     groupReplicasByServer,
-    replicaServer,
     fdSeparator,
     kb,
     mb,
@@ -199,7 +201,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 (chunkNo :: FileChunk -> Int) chunks
+    chunkNos = map (\c -> c.chunkNo) chunks
     chunksSize = fromIntegral . foldl' (\s FileChunk {chunkSize} -> s + unFileSize chunkSize) 0
 
 encodeFileDescription :: FileDescription p -> YAMLFileDescription
@@ -257,7 +259,7 @@ instance (ToField a) => ToField (FileSize a) where toField (FileSize s) = toFiel
 
 groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [[FileServerReplica]]
 groupReplicasByServer defChunkSize =
-  groupAllOn replicaServer . unfoldChunksToReplicas defChunkSize
+  groupAllOn (\r -> r.server) . unfoldChunksToReplicas defChunkSize
 
 encodeFileReplicas :: FileSize Word32 -> [FileChunk] -> [YAMLServerReplicas]
 encodeFileReplicas defChunkSize =
@@ -265,13 +267,10 @@ encodeFileReplicas defChunkSize =
   where
     encodeServerReplicas fs =
       YAMLServerReplicas
-        { server = replicaServer $ head fs, -- groupAllOn guarantees that fs is not empty
+        { server = (head fs).server, -- groupAllOn guarantees that fs is not empty
           chunks = map (B.unpack . encodeServerReplica) fs
         }
 
-replicaServer :: FileServerReplica -> XFTPServer
-replicaServer = server
-
 encodeServerReplica :: FileServerReplica -> ByteString
 encodeServerReplica FileServerReplica {chunkNo, replicaId, replicaKey, digest, chunkSize} =
   bshow chunkNo
@@ -323,7 +322,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 (chunkNo :: FileChunk -> Int) . map reverseReplicas . M.elems <$> foldChunks sd fs
+  sortOn (\c -> c.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)

src/Simplex/FileTransfer/Server.hs

@@ -12,6 +12,7 @@
 module Simplex.FileTransfer.Server where
 
 import Control.Logger.Simple
+import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader

src/Simplex/FileTransfer/Server/Main.hs

@@ -32,7 +32,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
 xftpServerVersion :: String
-xftpServerVersion = "1.0.1"
+xftpServerVersion = "1.1.0"
 
 xftpServerCLI :: FilePath -> FilePath -> IO ()
 xftpServerCLI cfgPath logPath = do

src/Simplex/FileTransfer/Transport.hs

@@ -16,7 +16,9 @@ module Simplex.FileTransfer.Transport
 where
 
 import qualified Control.Exception as E
+import Control.Monad
 import Control.Monad.Except
+import Control.Monad.IO.Class
 import qualified Data.ByteArray as BA
 import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)

src/Simplex/Messaging/Agent.hs

@@ -8,12 +8,15 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
+
 -- |
 -- Module      : Simplex.Messaging.Agent
 -- Copyright   : (c) simplex.chat
@@ -100,8 +103,8 @@ module Simplex.Messaging.Agent
   )
 where
 
-import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple (logError, logInfo, showText)
+import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
@@ -727,7 +730,7 @@ subscribeConnections' c connIds = do
       ContactConnection _ rq -> Right [rq]
       NewConnection _ -> Left (Right ())
     sndSubResult :: SndQueue -> Either AgentErrorType ()
-    sndSubResult sq = case status (sq :: SndQueue) of
+    sndSubResult SndQueue {status} = case status of
       Confirmed -> Right ()
       Active -> Left $ CONN SIMPLEX
       _ -> Left $ INTERNAL "unexpected queue status"
@@ -934,7 +937,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 ((replaceQId ==) . dbQId) rqs of
+                case find (\q -> replaceQId == q.dbQueueId) rqs of
                   Just rq1 -> when (status == Confirmed) $ do
                     secureQueue c rq' senderKey
                     withStore' c $ \db -> setRcvQueueStatus db rq' Secured
@@ -1191,7 +1194,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' -> dbQId sq' == replacedId && not (sameQueue addr sq')) sqs of
+                          case removeQP (\sq' -> sq'.dbQueueId == 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
@@ -1306,7 +1309,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 ((Just (dbQId rq) ==) . dbReplaceQId) rqs
+            let (delRqs, keepRqs) = L.partition (\q -> Just rq.dbQueueId == q.dbReplaceQueueId) rqs
             case L.nonEmpty keepRqs of
               Just rqs' -> do
                 rq' <- withStore' c $ \db -> do
@@ -1424,7 +1427,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 ("", qConnId rq, APC SAEConn $ DEL_RCVQ (qServer rq) (queueId rq) e_)
+    notifyRQ rq e_ = notify ("", rq.connId, 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
@@ -1869,7 +1872,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 ((replacedId ==) . dbQId) rqs of
+                            case find (\q -> replacedId == q.dbQueueId) rqs of
                               Just rq'@RcvQueue {server, rcvId} -> do
                                 checkRQSwchStatus rq' RSSendingQUSE
                                 void $ withStore' c $ \db -> setRcvSwitchStatus db rq' $ Just RSReceivedMessage
@@ -2144,7 +2147,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 ((Just dbQueueId ==) . dbReplaceQId) sqs
+                    let (delSqs, keepSqs) = L.partition (\q -> Just dbQueueId == q.dbReplaceQueueId) sqs
                     case L.nonEmpty keepSqs of
                       Just sqs' -> do
                         -- move inside case?
@@ -2195,7 +2198,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 ((replaceQId ==) . dbQId) sqs of
+                case find (\q -> replaceQId == q.dbQueueId) sqs of
                   Just sq1 -> do
                     checkSQSwchStatus sq1 SSSendingQKEY
                     logServer "<--" c srv rId $ "MSG <QUSE> " <> logSecret (snd addr)

src/Simplex/Messaging/Agent/Client.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -104,9 +105,10 @@ where
 import Control.Applicative ((<|>))
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
-import Control.Concurrent.STM (retry, stateTVar, throwSTM)
+import Control.Concurrent.STM (retry, throwSTM)
 import Control.Exception (AsyncException (..))
 import Control.Logger.Simple
+import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
@@ -423,7 +425,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 qConnId qs
+          let cs = S.fromList $ map (\q -> q.connId) qs
           cs' <- RQ.getConns $ activeSubs c
           pure (qs, S.toList $ cs `S.difference` cs')
 
@@ -811,7 +813,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 (qUserId q) (qServer q) (qConnId q)
+mkSMPTSession q = mkTSession q.userId (qServer q) q.connId
 
 getSessionMode :: AgentMonad' m => AgentClient -> m TransportSessionMode
 getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -6,6 +6,8 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
+
 module Simplex.Messaging.Agent.NtfSubSupervisor
   ( runNtfSupervisor,
     nsUpdateToken,
@@ -17,7 +19,6 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
   )
 where
 
-import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple (logError, logInfo)
 import Control.Monad
 import Control.Monad.Except
@@ -51,13 +52,13 @@ runNtfSupervisor c = do
   ns <- asks ntfSupervisor
   forever $ do
     cmd@(connId, _) <- atomically . readTBQueue $ ntfSubQ ns
-    handleError connId . agentOperationBracket c AONtfNetwork waitUntilActive $
+    handleErr connId . agentOperationBracket c AONtfNetwork waitUntilActive $
       runExceptT (processNtfSub c cmd) >>= \case
         Left e -> notifyErr connId e
         Right _ -> return ()
   where
-    handleError :: ConnId -> m () -> m ()
-    handleError connId = E.handle $ \(e :: E.SomeException) -> do
+    handleErr :: ConnId -> m () -> m ()
+    handleErr connId = E.handle $ \(e :: E.SomeException) -> do
       logError $ "runNtfSupervisor error " <> tshow e
       notifyErr connId e
     notifyErr connId e = notifyInternalError c connId $ "runNtfSupervisor error " <> show e

src/Simplex/Messaging/Agent/Protocol.hs

@@ -80,6 +80,8 @@ module Simplex.Messaging.Agent.Protocol
     SMPServerWithAuth,
     SrvLoc (..),
     SMPQueue (..),
+    qAddress,
+    sameQueue,
     sameQAddress,
     noAuthSrv,
     SMPQueueUri (..),
@@ -1195,8 +1197,15 @@ updateSMPServerHosts srv@ProtocolServer {host} = case host of
 
 class SMPQueue q where
   qServer :: q -> SMPServer
-  qAddress :: q -> (SMPServer, SMP.QueueId)
-  sameQueue :: (SMPServer, SMP.QueueId) -> q -> Bool
+  queueId :: q -> SMP.QueueId
+
+qAddress :: SMPQueue q => q -> (SMPServer, SMP.QueueId)
+qAddress q = (qServer q, queueId q)
+{-# INLINE qAddress #-}
+
+sameQueue :: SMPQueue q => (SMPServer, SMP.QueueId) -> q -> Bool
+sameQueue addr q = sameQAddress addr (qAddress q)
+{-# INLINE sameQueue #-}
 
 data SMPQueueInfo = SMPQueueInfo {clientVersion :: Version, queueAddress :: SMPQueueAddress}
   deriving (Eq, Show)
@@ -1241,26 +1250,20 @@ data SMPQueueAddress = SMPQueueAddress
 instance SMPQueue SMPQueueUri where
   qServer SMPQueueUri {queueAddress} = qServer queueAddress
   {-# INLINE qServer #-}
-  qAddress SMPQueueUri {queueAddress} = qAddress queueAddress
-  {-# INLINE qAddress #-}
-  sameQueue addr q = sameQAddress addr (qAddress q)
-  {-# INLINE sameQueue #-}
+  queueId SMPQueueUri {queueAddress} = queueId queueAddress
+  {-# INLINE queueId #-}
 
 instance SMPQueue SMPQueueInfo where
   qServer SMPQueueInfo {queueAddress} = qServer queueAddress
   {-# INLINE qServer #-}
-  qAddress SMPQueueInfo {queueAddress} = qAddress queueAddress
-  {-# INLINE qAddress #-}
-  sameQueue addr q = sameQAddress addr (qAddress q)
-  {-# INLINE sameQueue #-}
+  queueId SMPQueueInfo {queueAddress} = queueId queueAddress
+  {-# INLINE queueId #-}
 
 instance SMPQueue SMPQueueAddress where
   qServer SMPQueueAddress {smpServer} = smpServer
   {-# INLINE qServer #-}
-  qAddress SMPQueueAddress {smpServer, senderId} = (smpServer, senderId)
-  {-# INLINE qAddress #-}
-  sameQueue addr q = sameQAddress addr (qAddress q)
-  {-# INLINE sameQueue #-}
+  queueId SMPQueueAddress {senderId} = senderId
+  {-# INLINE queueId #-}
 
 sameQAddress :: (SMPServer, SMP.QueueId) -> (SMPServer, SMP.QueueId) -> Bool
 sameQAddress (srv, qId) (srv', qId') = sameSrvAddr srv srv' && qId == qId'

src/Simplex/Messaging/Agent/Server.hs

@@ -11,7 +11,7 @@ module Simplex.Messaging.Agent.Server
 where
 
 import Control.Logger.Simple (logInfo)
-import Control.Monad.Except
+import Control.Monad
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
 import Crypto.Random (MonadRandom)

src/Simplex/Messaging/Agent/Store.hs

@@ -1,11 +1,14 @@
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -24,6 +27,7 @@ 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
@@ -36,7 +40,6 @@ import Simplex.Messaging.Protocol
     NotifierId,
     NtfPrivateSignKey,
     NtfPublicVerifyKey,
-    QueueId,
     RcvDhSecret,
     RcvNtfDhSecret,
     RcvPrivateSignKey,
@@ -144,18 +147,14 @@ sndQueueInfo SndQueue {server, sndSwchStatus} =
 instance SMPQueue RcvQueue where
   qServer RcvQueue {server} = server
   {-# INLINE qServer #-}
-  qAddress RcvQueue {server, rcvId} = (server, rcvId)
-  {-# INLINE qAddress #-}
-  sameQueue addr q = sameQAddress addr (qAddress q)
-  {-# INLINE sameQueue #-}
+  queueId RcvQueue {rcvId} = rcvId
+  {-# INLINE queueId #-}
 
 instance SMPQueue SndQueue where
   qServer SndQueue {server} = server
   {-# INLINE qServer #-}
-  qAddress SndQueue {server, sndId} = (server, sndId)
-  {-# INLINE qAddress #-}
-  sameQueue addr q = sameQAddress addr (qAddress q)
-  {-# INLINE sameQueue #-}
+  queueId SndQueue {sndId} = sndId
+  {-# INLINE queueId #-}
 
 findQ :: SMPQueue q => (SMPServer, SMP.QueueId) -> NonEmpty q -> Maybe q
 findQ = find . sameQueue
@@ -183,39 +182,16 @@ switchingRQ = find $ isJust . rcvSwchStatus
 {-# INLINE switchingRQ #-}
 
 updatedQs :: SMPQueueRec q => q -> NonEmpty q -> NonEmpty q
-updatedQs q = L.map $ \q' -> if dbQId q == dbQId q' then q else q'
+updatedQs q = L.map $ \q' -> if q.dbQueueId == q'.dbQueueId then q else q'
 {-# INLINE updatedQs #-}
 
-class SMPQueue q => SMPQueueRec q where
-  qUserId :: q -> UserId
-  qConnId :: q -> ConnId
-  queueId :: q -> QueueId
-  dbQId :: q -> Int64
-  dbReplaceQId :: q -> Maybe Int64
-
-instance SMPQueueRec RcvQueue where
-  qUserId = userId
-  {-# INLINE qUserId #-}
-  qConnId = connId
-  {-# INLINE qConnId #-}
-  queueId = rcvId
-  {-# INLINE queueId #-}
-  dbQId = dbQueueId
-  {-# INLINE dbQId #-}
-  dbReplaceQId = dbReplaceQueueId
-  {-# INLINE dbReplaceQId #-}
-
-instance SMPQueueRec SndQueue where
-  qUserId = userId
-  {-# INLINE qUserId #-}
-  qConnId = connId
-  {-# INLINE qConnId #-}
-  queueId = sndId
-  {-# INLINE queueId #-}
-  dbQId = dbQueueId
-  {-# INLINE dbQId #-}
-  dbReplaceQId = dbReplaceQueueId
-  {-# INLINE dbReplaceQId #-}
+type SMPQueueRec q =
+  ( SMPQueue q,
+    HasField "userId" q UserId,
+    HasField "connId" q ConnId,
+    HasField "dbQueueId" q Int64,
+    HasField "dbReplaceQueueId" q (Maybe Int64)
+  )
 
 -- * Connection types
 

src/Simplex/Messaging/Agent/Store/SQLite.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -18,7 +19,9 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module Simplex.Messaging.Agent.Store.SQLite
   ( SQLiteStore (..),
@@ -211,8 +214,9 @@ module Simplex.Messaging.Agent.Store.SQLite
   )
 where
 
-import Control.Concurrent.STM (stateTVar)
+import Control.Monad
 import Control.Monad.Except
+import Control.Monad.IO.Class
 import Crypto.Random (ChaChaDRG, randomBytesGenerate)
 import Data.Aeson (ToJSON)
 import qualified Data.Aeson as J
@@ -1954,7 +1958,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" := sndMsgId (msgMeta :: MsgMeta),
+    [ ":last_external_snd_msg_id" := msgMeta.sndMsgId,
       ":last_rcv_msg_hash" := internalHash,
       ":conn_id" := connId,
       ":last_internal_rcv_msg_id" := internalRcvId

src/Simplex/Messaging/Agent/TAsyncs.hs

@@ -1,6 +1,5 @@
 module Simplex.Messaging.Agent.TAsyncs where
 
-import Control.Concurrent.STM (stateTVar)
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM

src/Simplex/Messaging/Client/Agent.hs

@@ -14,6 +14,7 @@ module Simplex.Messaging.Client.Agent where
 import Control.Concurrent (forkIO)
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
 import Control.Logger.Simple
+import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Trans.Except
@@ -39,7 +40,7 @@ import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPS
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (catchAll_, tryE, ($>>=), toChunks)
+import Simplex.Messaging.Util (catchAll_, ($>>=), toChunks)
 import System.Timeout (timeout)
 import UnliftIO (async)
 import UnliftIO.Exception (Exception)
@@ -272,13 +273,13 @@ withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPE
 subscribeQueue :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> ExceptT SMPClientError IO ()
 subscribeQueue ca srv sub = do
   atomically $ addPendingSubscription ca srv sub
-  withSMP ca srv $ \smp -> subscribe_ smp `catchE` handleError
+  withSMP ca srv $ \smp -> subscribe_ smp `catchE` handleErr
   where
     subscribe_ smp = do
       smpSubscribe smp sub
       atomically $ addSubscription ca srv sub
 
-    handleError e = do
+    handleErr e = do
       atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $
         removePendingSubscription ca srv $ fst sub
       throwE e

src/Simplex/Messaging/Crypto.hs

@@ -149,6 +149,7 @@ where
 
 import Control.Concurrent.STM
 import Control.Exception (Exception)
+import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Trans.Except
 import Crypto.Cipher.AES (AES256)

src/Simplex/Messaging/Crypto/Ratchet.hs

@@ -15,6 +15,7 @@
 module Simplex.Messaging.Crypto.Ratchet where
 
 import Control.Monad.Except
+import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import Crypto.Cipher.AES (AES256)
 import Crypto.Hash (SHA512)
@@ -38,7 +39,6 @@ import Simplex.Messaging.Crypto
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (blobFieldDecoder, parseE, parseE')
-import Simplex.Messaging.Util (tryE)
 import Simplex.Messaging.Version
 
 currentE2EEncryptVersion :: Version

src/Simplex/Messaging/Notifications/Server.hs

@@ -12,8 +12,8 @@
 
 module Simplex.Messaging.Notifications.Server where
 
-import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple
+import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Bifunctor (second)

src/Simplex/Messaging/Notifications/Server/Main.hs

@@ -30,7 +30,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
 ntfServerVersion :: String
-ntfServerVersion = "1.5.1"
+ntfServerVersion = "1.6.0"
 
 defaultSMPBatchDelay :: Int
 defaultSMPBatchDelay = 10000

src/Simplex/Messaging/Notifications/Server/Push/APNS.hs

@@ -12,7 +12,9 @@ module Simplex.Messaging.Notifications.Server.Push.APNS where
 
 import Control.Exception (Exception)
 import Control.Logger.Simple
+import Control.Monad
 import Control.Monad.Except
+import Control.Monad.IO.Class
 import Crypto.Hash.Algorithms (SHA256 (..))
 import qualified Crypto.PubKey.ECC.ECDSA as EC
 import qualified Crypto.PubKey.ECC.Types as ECT

src/Simplex/Messaging/Notifications/Server/Stats.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Messaging.Notifications.Server.Stats where
@@ -56,30 +57,30 @@ newNtfServerStats ts = do
 
 getNtfServerStatsData :: NtfServerStats -> STM NtfServerStatsData
 getNtfServerStatsData s = do
-  _fromTime <- readTVar $ fromTime (s :: NtfServerStats)
-  _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
+  _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
   pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}
 
 setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> STM ()
 setNtfServerStats s d = do
-  writeTVar (fromTime (s :: NtfServerStats)) $! _fromTime (d :: NtfServerStatsData)
-  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)
+  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)
 
 instance StrEncoding NtfServerStatsData where
   strEncode NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs} =

src/Simplex/Messaging/Notifications/Server/StoreLog.hs

@@ -5,6 +5,8 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
+
 module Simplex.Messaging.Notifications.Server.StoreLog
   ( StoreLog,
     NtfStoreLogRecord (..),

src/Simplex/Messaging/Server.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
@@ -66,12 +67,12 @@ import Simplex.Messaging.Encoding (Encoding (smpEncode))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Control
-import Simplex.Messaging.Server.Env.STM
+import Simplex.Messaging.Server.Env.STM as Env
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore
 import Simplex.Messaging.Server.MsgStore.STM
 import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.Server.QueueStore.STM
+import Simplex.Messaging.Server.QueueStore.STM as QS
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.TMap (TMap)
@@ -113,7 +114,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
   restoreServerStats
   raceAny_
     ( serverThread s subscribedQ subscribers subscriptions cancelSub :
-      serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) :
+      serverThread s ntfSubscribedQ Env.notifiers ntfSubscriptions (\_ -> pure ()) :
       map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg
     )
     `finally` withLock (savingLock s) "final" (saveServer False)
@@ -723,11 +724,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' = msgId (msg :: Message)
-            msgTs' = msgTs (msg :: Message)
+            msgId' = msg.msgId
+            msgTs' = msg.msgTs
 
         setDelivered :: Sub -> Message -> STM Bool
-        setDelivered s msg = tryPutTMVar (delivered s) $ msgId (msg :: Message)
+        setDelivered s msg = tryPutTMVar (delivered s) $ msg.msgId
 
         getStoreMsgQueue :: T.Text -> RecipientId -> m MsgQueue
         getStoreMsgQueue name rId = time (name <> " getMsgQueue") $ do
@@ -827,7 +828,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 (msgId (msg :: Message))
+              when logFull . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode msg.msgId
             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

src/Simplex/Messaging/Transport/Client.hs

@@ -21,7 +21,6 @@ module Simplex.Messaging.Transport.Client
 where
 
 import Control.Applicative (optional)
-import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Attoparsec.ByteString.Char8 as A

src/Simplex/Messaging/Transport/HTTP2/Client.hs

@@ -9,7 +9,7 @@ module Simplex.Messaging.Transport.HTTP2.Client where
 import Control.Concurrent.Async
 import Control.Exception (IOException, try)
 import qualified Control.Exception as E
-import Control.Monad.Except
+import Control.Monad
 import Data.ByteString.Char8 (ByteString)
 import Data.Functor (($>))
 import Data.Time (UTCTime, getCurrentTime)

src/Simplex/Messaging/Transport/Server.hs

@@ -17,9 +17,8 @@ module Simplex.Messaging.Transport.Server
 where
 
 import Control.Applicative ((<|>))
-import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple
-import Control.Monad.Except
+import Control.Monad
 import Control.Monad.IO.Unlift
 import qualified Crypto.Store.X509 as SX
 import Data.Default (def)

src/Simplex/Messaging/Util.hs

@@ -5,9 +5,9 @@ module Simplex.Messaging.Util where
 
 import Control.Concurrent (threadDelay)
 import qualified Control.Exception as E
+import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
-import Control.Monad.Trans.Except
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -66,14 +66,6 @@ liftEitherWith :: (MonadError e' m) => (e -> e') -> Either e a -> m a
 liftEitherWith f = liftEither . first f
 {-# INLINE liftEitherWith #-}
 
-tryError :: MonadError e m => m a -> m (Either e a)
-tryError action = (Right <$> action) `catchError` (pure . Left)
-{-# INLINE tryError #-}
-
-tryE :: Monad m => ExceptT e m a -> ExceptT e m (Either e a)
-tryE m = (Right <$> m) `catchE` (pure . Left)
-{-# INLINE tryE #-}
-
 liftE :: (e -> e') -> ExceptT e IO a -> ExceptT e' IO a
 liftE f a = ExceptT $ first f <$> runExceptT a
 {-# INLINE liftE #-}