diff --git a/package.yaml b/package.yaml index 03f60c6de..390d576d0 100644 --- a/package.yaml +++ b/package.yaml @@ -23,7 +23,7 @@ extra-source-files: - migrations/*.* dependencies: - - ansi-terminal >= 0.10 && < 0.12 + - ansi-terminal >= 0.8 && < 0.12 - asn1-encoding == 0.9.* - asn1-types == 0.3.* - async == 2.2.* @@ -32,30 +32,30 @@ dependencies: - base64-bytestring >= 1.0 && < 1.3 - bytestring == 0.10.* - composition == 1.0.* - - constraints >= 0.12 && < 0.14 - - containers == 0.6.* - - cryptonite >= 0.27 && < 0.30 + - constraints >= 0.10 && < 0.14 + - containers >= 0.5 && < 0.7 + - cryptonite >= 0.25 && < 0.30 - direct-sqlite == 2.3.* - directory == 1.3.* - - file-embed >= 0.0.14.0 && <= 0.0.15.0 + - file-embed >= 0.0.10.0 && <= 0.0.15.0 - filepath == 1.4.* - - generic-random >= 1.3 && < 1.5 + - generic-random >= 1.2 && < 1.5 - iso8601-time == 0.1.* - - memory == 0.15.* + - memory >= 0.14 && < 0.16 - mtl == 2.2.* - - network == 3.1.* + - network >= 2.6 && < 3.2 - network-transport == 0.5.* - - QuickCheck == 2.14.* + - QuickCheck >= 2.11 && < 2.15 - random >= 1.1 && < 1.3 - - simple-logger == 0.1.* + - simple-logger == 0.0.4 - sqlite-simple == 0.4.* - - stm == 2.5.* - - template-haskell == 2.16.* + - stm >= 2.4 && < 2.6 + - template-haskell >= 2.13 && < 2.17 - text == 1.2.* - - time == 1.9.* + - time >= 1.8 && < 1.10 - transformers == 0.5.* - unliftio == 0.2.* - - unliftio-core == 0.2.* + - unliftio-core >= 0.1 && < 0.3 - websockets == 0.12.* - x509 == 1.7.* @@ -68,8 +68,8 @@ executables: main: Main.hs dependencies: - cryptostore == 0.2.* - - ini == 0.4.* - - optparse-applicative >= 0.15 && < 0.17 + - ini >= 0.3 && < 0.5 + - optparse-applicative >= 0.14 && < 0.17 - simplexmq ghc-options: - -threaded @@ -88,10 +88,10 @@ tests: main: Test.hs dependencies: - simplexmq - - hspec == 2.7.* - - hspec-core == 2.7.* + - hspec >= 2.5 && < 2.8 + - hspec-core >= 2.5 && < 2.8 - HUnit == 1.6.* - - QuickCheck == 2.14.* + - QuickCheck >= 2.11 && < 2.15 - timeit == 2.0.* ghc-options: diff --git a/simplexmq.cabal b/simplexmq.cabal index aeea86e98..e33e17245 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -61,8 +61,8 @@ library src ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns build-depends: - QuickCheck ==2.14.* - , ansi-terminal >=0.10 && <0.12 + QuickCheck >=2.11 && <2.15 + , ansi-terminal >=0.8 && <0.12 , asn1-encoding ==0.9.* , asn1-types ==0.3.* , async ==2.2.* @@ -71,29 +71,29 @@ library , base64-bytestring >=1.0 && <1.3 , bytestring ==0.10.* , composition ==1.0.* - , constraints >=0.12 && <0.14 - , containers ==0.6.* - , cryptonite >=0.27 && <0.30 + , constraints >=0.10 && <0.14 + , containers >=0.5 && <0.7 + , cryptonite >=0.25 && <0.30 , direct-sqlite ==2.3.* , directory ==1.3.* - , file-embed >=0.0.14.0 && <=0.0.15.0 + , file-embed >=0.0.10.0 && <=0.0.15.0 , filepath ==1.4.* - , generic-random >=1.3 && <1.5 + , generic-random >=1.2 && <1.5 , iso8601-time ==0.1.* - , memory ==0.15.* + , memory >=0.14 && <0.16 , mtl ==2.2.* - , network ==3.1.* + , network >=2.6 && <3.2 , network-transport ==0.5.* , random >=1.1 && <1.3 - , simple-logger ==0.1.* + , simple-logger ==0.0.4 , sqlite-simple ==0.4.* - , stm ==2.5.* - , template-haskell ==2.16.* + , stm >=2.4 && <2.6 + , template-haskell >=2.13 && <2.17 , text ==1.2.* - , time ==1.9.* + , time >=1.8 && <1.10 , transformers ==0.5.* , unliftio ==0.2.* - , unliftio-core ==0.2.* + , unliftio-core >=0.1 && <0.3 , websockets ==0.12.* , x509 ==1.7.* default-language: Haskell2010 @@ -106,8 +106,8 @@ executable smp-agent apps/smp-agent ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded build-depends: - QuickCheck ==2.14.* - , ansi-terminal >=0.10 && <0.12 + QuickCheck >=2.11 && <2.15 + , ansi-terminal >=0.8 && <0.12 , asn1-encoding ==0.9.* , asn1-types ==0.3.* , async ==2.2.* @@ -116,30 +116,30 @@ executable smp-agent , base64-bytestring >=1.0 && <1.3 , bytestring ==0.10.* , composition ==1.0.* - , constraints >=0.12 && <0.14 - , containers ==0.6.* - , cryptonite >=0.27 && <0.30 + , constraints >=0.10 && <0.14 + , containers >=0.5 && <0.7 + , cryptonite >=0.25 && <0.30 , direct-sqlite ==2.3.* , directory ==1.3.* - , file-embed >=0.0.14.0 && <=0.0.15.0 + , file-embed >=0.0.10.0 && <=0.0.15.0 , filepath ==1.4.* - , generic-random >=1.3 && <1.5 + , generic-random >=1.2 && <1.5 , iso8601-time ==0.1.* - , memory ==0.15.* + , memory >=0.14 && <0.16 , mtl ==2.2.* - , network ==3.1.* + , network >=2.6 && <3.2 , network-transport ==0.5.* , random >=1.1 && <1.3 - , simple-logger ==0.1.* + , simple-logger ==0.0.4 , simplexmq , sqlite-simple ==0.4.* - , stm ==2.5.* - , template-haskell ==2.16.* + , stm >=2.4 && <2.6 + , template-haskell >=2.13 && <2.17 , text ==1.2.* - , time ==1.9.* + , time >=1.8 && <1.10 , transformers ==0.5.* , unliftio ==0.2.* - , unliftio-core ==0.2.* + , unliftio-core >=0.1 && <0.3 , websockets ==0.12.* , x509 ==1.7.* default-language: Haskell2010 @@ -152,8 +152,8 @@ executable smp-server apps/smp-server ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded build-depends: - QuickCheck ==2.14.* - , ansi-terminal >=0.10 && <0.12 + QuickCheck >=2.11 && <2.15 + , ansi-terminal >=0.8 && <0.12 , asn1-encoding ==0.9.* , asn1-types ==0.3.* , async ==2.2.* @@ -162,33 +162,33 @@ executable smp-server , base64-bytestring >=1.0 && <1.3 , bytestring ==0.10.* , composition ==1.0.* - , constraints >=0.12 && <0.14 - , containers ==0.6.* - , cryptonite >=0.27 && <0.30 + , constraints >=0.10 && <0.14 + , containers >=0.5 && <0.7 + , cryptonite >=0.25 && <0.30 , cryptostore ==0.2.* , direct-sqlite ==2.3.* , directory ==1.3.* - , file-embed >=0.0.14.0 && <=0.0.15.0 + , file-embed >=0.0.10.0 && <=0.0.15.0 , filepath ==1.4.* - , generic-random >=1.3 && <1.5 - , ini ==0.4.* + , generic-random >=1.2 && <1.5 + , ini >=0.3 && <0.5 , iso8601-time ==0.1.* - , memory ==0.15.* + , memory >=0.14 && <0.16 , mtl ==2.2.* - , network ==3.1.* + , network >=2.6 && <3.2 , network-transport ==0.5.* - , optparse-applicative >=0.15 && <0.17 + , optparse-applicative >=0.14 && <0.17 , random >=1.1 && <1.3 - , simple-logger ==0.1.* + , simple-logger ==0.0.4 , simplexmq , sqlite-simple ==0.4.* - , stm ==2.5.* - , template-haskell ==2.16.* + , stm >=2.4 && <2.6 + , template-haskell >=2.13 && <2.17 , text ==1.2.* - , time ==1.9.* + , time >=1.8 && <1.10 , transformers ==0.5.* , unliftio ==0.2.* - , unliftio-core ==0.2.* + , unliftio-core >=0.1 && <0.3 , websockets ==0.12.* , x509 ==1.7.* default-language: Haskell2010 @@ -210,8 +210,8 @@ test-suite smp-server-test ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns build-depends: HUnit ==1.6.* - , QuickCheck ==2.14.* - , ansi-terminal >=0.10 && <0.12 + , QuickCheck >=2.11 && <2.15 + , ansi-terminal >=0.8 && <0.12 , asn1-encoding ==0.9.* , asn1-types ==0.3.* , async ==2.2.* @@ -220,33 +220,33 @@ test-suite smp-server-test , base64-bytestring >=1.0 && <1.3 , bytestring ==0.10.* , composition ==1.0.* - , constraints >=0.12 && <0.14 - , containers ==0.6.* - , cryptonite >=0.27 && <0.30 + , constraints >=0.10 && <0.14 + , containers >=0.5 && <0.7 + , cryptonite >=0.25 && <0.30 , direct-sqlite ==2.3.* , directory ==1.3.* - , file-embed >=0.0.14.0 && <=0.0.15.0 + , file-embed >=0.0.10.0 && <=0.0.15.0 , filepath ==1.4.* - , generic-random >=1.3 && <1.5 - , hspec ==2.7.* - , hspec-core ==2.7.* + , generic-random >=1.2 && <1.5 + , hspec >=2.5 && <2.8 + , hspec-core >=2.5 && <2.8 , iso8601-time ==0.1.* - , memory ==0.15.* + , memory >=0.14 && <0.16 , mtl ==2.2.* - , network ==3.1.* + , network >=2.6 && <3.2 , network-transport ==0.5.* , random >=1.1 && <1.3 - , simple-logger ==0.1.* + , simple-logger ==0.0.4 , simplexmq , sqlite-simple ==0.4.* - , stm ==2.5.* - , template-haskell ==2.16.* + , stm >=2.4 && <2.6 + , template-haskell >=2.13 && <2.17 , text ==1.2.* - , time ==1.9.* + , time >=1.8 && <1.10 , timeit ==2.0.* , transformers ==0.5.* , unliftio ==0.2.* - , unliftio-core ==0.2.* + , unliftio-core >=0.1 && <0.3 , websockets ==0.12.* , x509 ==1.7.* default-language: Haskell2010 diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 18dd0d845..9d8705741 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -6,7 +6,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -52,7 +51,6 @@ module Simplex.Messaging.Agent ) where -import Control.Concurrent.STM (stateTVar) import Control.Logger.Simple (logInfo, showText) import Control.Monad.Except import Control.Monad.IO.Unlift (MonadUnliftIO) @@ -83,7 +81,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (MsgBody, SenderPublicKey) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), runTransportServer) -import Simplex.Messaging.Util (bshow, tryError) +import Simplex.Messaging.Util (bshow, tryError, stateTVar) import System.Random (randomR) import UnliftIO.Async (Async, async, race_) import qualified UnliftIO.Exception as E @@ -333,7 +331,7 @@ subscribeConnection' c connId = resumeInterval :: m RetryInterval resumeInterval = do r <- asks $ retryInterval . config - pure r {initialInterval = 5_000_000} + pure r {initialInterval = 5000000} -- | Send message to the connection (SEND command) in Reader monad sendMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> MsgBody -> m AgentMsgId diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index cc9cfb340..d63f0538d 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -36,7 +36,6 @@ module Simplex.Messaging.Agent.Client where import Control.Concurrent.Async (Async, async, uninterruptibleCancel) -import Control.Concurrent.STM (stateTVar) import Control.Logger.Simple import Control.Monad.Except import Control.Monad.IO.Unlift @@ -59,7 +58,7 @@ import Simplex.Messaging.Agent.Store import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgBody, QueueId, SenderPublicKey) -import Simplex.Messaging.Util (bshow, liftEitherError, liftError) +import Simplex.Messaging.Util (bshow, liftEitherError, liftError, stateTVar) import UnliftIO.Exception (IOException) import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -86,9 +85,9 @@ data AgentClient = AgentClient newAgentClient :: Env -> STM AgentClient newAgentClient agentEnv = do let qSize = tbqSize $ config agentEnv - rcvQ <- newTBQueue qSize - subQ <- newTBQueue qSize - msgQ <- newTBQueue qSize + rcvQ <- newTBQueue $ fromIntegral qSize + subQ <- newTBQueue $ fromIntegral qSize + msgQ <- newTBQueue $ fromIntegral qSize smpClients <- newTVar M.empty subscrSrvrs <- newTVar M.empty subscrConns <- newTVar M.empty diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 6a063d4dd..6660c921e 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NumericUnderscores #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} module Simplex.Messaging.Agent.Env.SQLite where @@ -33,7 +32,7 @@ data AgentConfig = AgentConfig } minute :: Int -minute = 60_000_000 +minute = 60000000 defaultAgentConfig :: AgentConfig defaultAgentConfig = @@ -48,15 +47,15 @@ defaultAgentConfig = smpCfg = smpDefaultConfig, retryInterval = RetryInterval - { initialInterval = 1_000_000, + { initialInterval = 1000000, increaseAfter = minute, maxInterval = 10 * minute }, reconnectInterval = RetryInterval - { initialInterval = 1_000_000, - increaseAfter = 10_000_000, - maxInterval = 10_000_000 + { initialInterval = 1000000, + increaseAfter = 10000000, + maxInterval = 10000000 } } diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 44e42cdd4..466129562 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -610,7 +610,7 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody return (corrId, connId, fullCmd) fromParty :: ACmd -> Either AgentErrorType (ACommand p) - fromParty (ACmd (p :: p1) cmd) = case testEquality party p of + fromParty (ACmd p cmd) = case testEquality party p of Just Refl -> Right cmd _ -> Left $ CMD PROHIBITED diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index fd8b3ced6..46b19f4f1 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 5d63af27c..c17490fcd 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -7,7 +7,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} @@ -54,7 +53,7 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Parsers (blobFieldParser) import Simplex.Messaging.Protocol (MsgBody) import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Util (bshow, liftIOEither) +import Simplex.Messaging.Util (bshow, liftIOEither, stateTVar) import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist) import System.Exit (exitFailure) import System.FilePath (takeDirectory) @@ -138,7 +137,7 @@ withConnection SQLiteStore {dbConnPool} = (atomically . writeTBQueue dbConnPool) withTransaction :: forall a. SQLiteStore -> (DB.Connection -> IO a) -> IO a -withTransaction st action = withConnection st $ loop 100 100_000 +withTransaction st action = withConnection st $ loop 100 100000 where loop :: Int -> Int -> DB.Connection -> IO a loop t tLim db = diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index f39dc2e05..929d50a40 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -4,7 +4,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -66,7 +65,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol import Simplex.Messaging.Transport (ATransport (..), TCP, THandle (..), TProxy, Transport (..), TransportError, clientHandshake, runTransportClient) import Simplex.Messaging.Transport.WebSockets (WS) -import Simplex.Messaging.Util (bshow, liftError, raceAny_) +import Simplex.Messaging.Util (bshow, liftError, raceAny_, stateTVar) import System.Timeout (timeout) -- | 'SMPClient' is a handle used to send commands to a specific SMP server. @@ -115,8 +114,8 @@ smpDefaultConfig = SMPClientConfig { qSize = 16, defaultTransport = ("5223", transport @TCP), - tcpTimeout = 4_000_000, - smpPing = 30_000_000, + tcpTimeout = 4000000, + smpPing = 30000000, smpBlockSize = Just 8192, smpCommandSize = 256 } @@ -142,8 +141,8 @@ getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing, smpBlock connected <- newTVar False clientCorrId <- newTVar 0 sentCommands <- newTVar M.empty - sndQ <- newTBQueue qSize - rcvQ <- newTBQueue qSize + sndQ <- newTBQueue $ fromIntegral qSize + rcvQ <- newTBQueue $ fromIntegral qSize return SMPClient { action = undefined, diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index ccd8f5f90..1a173e0b2 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -335,7 +335,7 @@ decrypt :: PrivateKey k => k -> ByteString -> ExceptT CryptoError IO ByteString decrypt pk msg'' = do let (encHeader, msg') = B.splitAt (privateKeySize pk) msg'' header <- decryptOAEP pk encHeader - Header {aesKey, ivBytes, authTag, msgSize} <- except $ parseHeader header + Header {aesKey, ivBytes, authTag, msgSize} <- ExceptT $ pure $ parseHeader header msg <- decryptAES aesKey ivBytes msg' authTag return $ B.take msgSize msg diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 3d4cd634c..cb8d69596 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -25,7 +25,6 @@ -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md module Simplex.Messaging.Server (runSMPServer, runSMPServerBlocking) where -import Control.Concurrent.STM (stateTVar) import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 5a0ebacea..a8b5a8f27 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -67,9 +67,9 @@ data Sub = Sub newServer :: Natural -> STM Server newServer qSize = do - subscribedQ <- newTBQueue qSize + subscribedQ <- newTBQueue $ fromIntegral qSize subscribers <- newTVar M.empty - ntfSubscribedQ <- newTBQueue qSize + ntfSubscribedQ <- newTBQueue $ fromIntegral qSize notifiers <- newTVar M.empty return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers} @@ -77,8 +77,8 @@ newClient :: Natural -> STM Client newClient qSize = do subscriptions <- newTVar M.empty ntfSubscriptions <- newTVar M.empty - rcvQ <- newTBQueue qSize - sndQ <- newTBQueue qSize + rcvQ <- newTBQueue $ fromIntegral qSize + sndQ <- newTBQueue $ fromIntegral qSize return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} newSubscription :: STM Sub diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index 6d0fb63a0..9bab9b810 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -29,7 +29,7 @@ instance MonadMsgStore STMMsgStore MsgQueue STM where maybe (newQ m) return $ M.lookup rId m where newQ m' = do - q <- MsgQueue <$> newTBQueue quota + q <- MsgQueue <$> newTBQueue (fromIntegral quota) writeTVar store . MsgStoreData $ M.insert rId q m' return q diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 06382563c..8cb83ab88 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -127,7 +126,7 @@ data ATransport = forall c. Transport c => ATransport (TProxy c) runTransportServer :: (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> (c -> m ()) -> m () runTransportServer started port server = do clients <- newTVarIO S.empty - E.bracket (liftIO $ startTCPServer started port) (liftIO . closeServer clients) \sock -> forever $ do + E.bracket (liftIO $ startTCPServer started port) (liftIO . closeServer clients) $ \sock -> forever $ do c <- liftIO $ acceptConnection sock tid <- forkFinally (server c) (const $ liftIO $ closeConnection c) atomically . modifyTVar clients $ S.insert tid @@ -149,7 +148,8 @@ startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted open addr = do sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) setSocketOption sock ReuseAddr 1 - withFdSocket sock setCloseOnExecIfNeeded + -- removed for GHC 8.4.4 + -- withFdSocket sock setCloseOnExecIfNeeded bind sock $ addrAddress addr listen sock 1024 return sock diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index d558a636a..436b8a664 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -5,6 +5,8 @@ module Simplex.Messaging.Util where +import Control.Concurrent.STM +import Control.Monad.Fail (MonadFail) import Control.Monad.Except import Control.Monad.IO.Unlift import Data.Bifunctor (first) @@ -63,3 +65,11 @@ ifM ba t f = ba >>= \b -> if b then t else f unlessM :: Monad m => m Bool -> m () -> m () unlessM b = ifM b $ pure () + +stateTVar :: TVar s -> (s -> (a, s)) -> STM a +stateTVar var f = do + s <- readTVar var + let (a, s') = f s -- since we destructure this, we are strict in f + writeTVar var s' + return a +{-# INLINE stateTVar #-} diff --git a/stack.yaml b/stack.yaml index 945175a35..cea859dbd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-18.13 +resolver: lts-12.26 # User packages to be built. # Various formats can be used as shown in the example below. @@ -35,9 +35,9 @@ packages: # forks / in-progress versions pinned to a git hash. For example: # extra-deps: - - cryptostore-0.2.1.0@sha256:9896e2984f36a1c8790f057fd5ce3da4cbcaf8aa73eb2d9277916886978c5b19,3881 + - cryptostore-0.2.0.0 - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 - - simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079 + - simple-logger-0.0.4 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 # - network-run-0.2.4@sha256:7dbb06def522dab413bce4a46af476820bffdff2071974736b06f52f4ab57c96,885 # - git: https://github.com/commercialhaskell/stack.git diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 73dd732c2..c1f4f6a34 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -29,7 +28,7 @@ agentTests (ATransport t) = do describe "Functional API" $ functionalAPITests (ATransport t) describe "SQLite store" storeTests describe "SMP agent protocol syntax" $ syntaxTests t - describe "Establishing duplex connection" do + describe "Establishing duplex connection" $ do it "should connect via one server and one agent" $ smpAgentTest2_1_1 $ testDuplexConnection t it "should connect via one server and one agent (random IDs)" $ @@ -42,12 +41,12 @@ agentTests (ATransport t) = do smpAgentTest2_2_2 $ testDuplexConnection t it "should connect via 2 servers and 2 agents (random IDs)" $ smpAgentTest2_2_2 $ testDuplexConnRandomIds t - describe "Connection subscriptions" do + describe "Connection subscriptions" $ do it "should connect via one server and one agent" $ smpAgentTest3_1_1 $ testSubscription t it "should send notifications to client when server disconnects" $ smpAgentServerTest $ testSubscrNotification t - describe "Message delivery" do + describe "Message delivery" $ do it "should deliver messages after losing server connection and re-connecting" $ smpAgentTest2_2_2_needs_server $ testMsgDeliveryServerRestart t it "should deliver pending messages after agent restarting" $ @@ -277,21 +276,21 @@ samplePublicKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSG syntaxTests :: forall c. Transport c => TProxy c -> Spec syntaxTests t = do it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX") - describe "NEW" do - describe "valid" do + describe "NEW" $ do + describe "valid" $ do -- TODO: add tests with defined connection alias it "without parameters" $ ("211", "", "NEW") >#>= \case ("211", _, "INV" : _) -> True; _ -> False - describe "invalid" do + describe "invalid" $ do -- TODO: add tests with defined connection alias it "with parameters" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX") - describe "JOIN" do - describe "valid" do + describe "JOIN" $ do + describe "valid" $ do -- TODO: ERROR no connection alias in the response (it does not generate it yet if not provided) -- TODO: add tests with defined connection alias it "using same server as in invitation" $ ("311", "a", "JOIN smp::localhost:5000::1234::" <> samplePublicKey <> " 14\nbob's connInfo") >#> ("311", "a", "ERR SMP AUTH") - describe "invalid" do + describe "invalid" $ do -- TODO: JOIN is not merged yet - to be added it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX") where diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 008e0c14b..251ff5ac6 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -12,7 +12,7 @@ import Control.Monad.IO.Unlift import SMPAgentClient import SMPClient (withSmpServer) import Simplex.Messaging.Agent -import Simplex.Messaging.Agent.Env.SQLite (dbFile) +import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..)) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Protocol (ErrorType (..), MsgBody) import Simplex.Messaging.Transport (ATransport (..)) diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 26d652ad9..ddaaf01bf 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -70,42 +69,42 @@ action `throwsError` e = runExceptT action `shouldReturn` Left e -- TODO add null port tests storeTests :: Spec storeTests = do - withStore2 do + withStore2 $ do describe "stress test" testConcurrentWrites - withStore do - describe "store setup" do + withStore $ do + describe "store setup" $ do testCompiledThreadsafe testForeignKeysEnabled - describe "store methods" do - describe "Queue and Connection management" do - describe "createRcvConn" do + describe "store methods" $ do + describe "Queue and Connection management" $ do + describe "createRcvConn" $ do testCreateRcvConn testCreateRcvConnRandomId testCreateRcvConnDuplicate - describe "createSndConn" do + describe "createSndConn" $ do testCreateSndConn testCreateSndConnRandomID testCreateSndConnDuplicate describe "getAllConnIds" testGetAllConnIds describe "getRcvConn" testGetRcvConn - describe "deleteConn" do + describe "deleteConn" $ do testDeleteRcvConn testDeleteSndConn testDeleteDuplexConn - describe "upgradeRcvConnToDuplex" do + describe "upgradeRcvConnToDuplex" $ do testUpgradeRcvConnToDuplex - describe "upgradeSndConnToDuplex" do + describe "upgradeSndConnToDuplex" $ do testUpgradeSndConnToDuplex - describe "set Queue status" do - describe "setRcvQueueStatus" do + describe "set Queue status" $ do + describe "setRcvQueueStatus" $ do testSetRcvQueueStatus testSetRcvQueueStatusNoQueue - describe "setSndQueueStatus" do + describe "setSndQueueStatus" $ do testSetSndQueueStatus testSetSndQueueStatusNoQueue testSetQueueStatusDuplex - describe "Msg management" do - describe "create Msg" do + describe "Msg management" $ do + describe "create Msg" $ do testCreateRcvMsg testCreateSndMsg testCreateRcvAndSndMsgs diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 99d2336ce..f89d8d621 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -164,9 +162,9 @@ cfg = smpDefaultConfig { qSize = 1, defaultTransport = (testPort, transport @TCP), - tcpTimeout = 500_000 + tcpTimeout = 500000 }, - retryInterval = (retryInterval defaultAgentConfig) {initialInterval = 50_000} + retryInterval = (retryInterval defaultAgentConfig) {initialInterval = 50000} } withSmpAgentThreadOn_ :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> m () -> (ThreadId -> m a) -> m a diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 6892baaea..e19b190ef 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -22,6 +21,7 @@ import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Server.StoreLog (openReadStoreLog) import Simplex.Messaging.Transport import Test.Hspec +import qualified Control.Concurrent as CC import UnliftIO.Concurrent import qualified UnliftIO.Exception as E import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, takeTMVar) @@ -111,6 +111,11 @@ withSmpServerThreadOn t port = (\started -> runSMPServerBlocking started cfg {transports = [(port, t)]}) (pure ()) +forkIOWithUnmask :: MonadUnliftIO m => ((forall a. m a -> m a) -> m ()) -> m ThreadId +forkIOWithUnmask m = + withRunInIO $ \run -> CC.forkIOWithUnmask $ \unmask -> run $ m $ liftIO . unmask . run +{-# INLINABLE forkIOWithUnmask #-} + serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a serverBracket process afterProcess f = do started <- newEmptyTMVarIO @@ -120,7 +125,7 @@ serverBracket process afterProcess f = do (\t -> waitFor started "start" >> f t) where waitFor started s = - 5_000_000 `timeout` atomically (takeTMVar started) >>= \case + 5000000 `timeout` atomically (takeTMVar started) >>= \case Nothing -> error $ "server did not " <> s _ -> pure () diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 3d328a4af..8bbd6d25c 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -31,10 +30,10 @@ rsaKeySize = 2048 `div` 8 serverTests :: ATransport -> Spec serverTests t = do describe "SMP syntax" $ syntaxTests t - describe "SMP queues" do + describe "SMP queues" $ do describe "NEW and KEY commands, SEND messages" $ testCreateSecure t describe "NEW, OFF and DEL commands, SEND messages" $ testCreateDelete t - describe "SMP messages" do + describe "SMP messages" $ do describe "duplex communication over 2 SMP connections" $ testDuplex t describe "switch subscription to another SMP queue" $ testSwitchSub t describe "Store log" $ testWithStoreLog t @@ -418,12 +417,12 @@ sampleSig = "\128\207*\159eq\220i!\"\157\161\130\184\226\246\232_\\\170`\180\160 syntaxTests :: ATransport -> Spec syntaxTests (ATransport t) = do it "unknown command" $ ("", "abcd", "1234", "HELLO") >#> ("", "abcd", "1234", "ERR CMD SYNTAX") - describe "NEW" do + describe "NEW" $ do it "no parameters" $ (sampleSig, "bcda", "", "NEW") >#> ("", "bcda", "", "ERR CMD SYNTAX") it "many parameters" $ (sampleSig, "cdab", "", "NEW 1 " <> samplePubKey) >#> ("", "cdab", "", "ERR CMD SYNTAX") it "no signature" $ ("", "dabc", "", "NEW " <> samplePubKey) >#> ("", "dabc", "", "ERR CMD NO_AUTH") it "queue ID" $ (sampleSig, "abcd", "12345678", "NEW " <> samplePubKey) >#> ("", "abcd", "12345678", "ERR CMD HAS_AUTH") - describe "KEY" do + describe "KEY" $ do it "valid syntax" $ (sampleSig, "bcda", "12345678", "KEY " <> samplePubKey) >#> ("", "bcda", "12345678", "ERR AUTH") it "no parameters" $ (sampleSig, "cdab", "12345678", "KEY") >#> ("", "cdab", "12345678", "ERR CMD SYNTAX") it "many parameters" $ (sampleSig, "dabc", "12345678", "KEY 1 " <> samplePubKey) >#> ("", "dabc", "12345678", "ERR CMD SYNTAX") @@ -433,7 +432,7 @@ syntaxTests (ATransport t) = do noParamsSyntaxTest "ACK" noParamsSyntaxTest "OFF" noParamsSyntaxTest "DEL" - describe "SEND" do + describe "SEND" $ do it "valid syntax 1" $ (sampleSig, "cdab", "12345678", "SEND 5 hello ") >#> ("", "cdab", "12345678", "ERR AUTH") it "valid syntax 2" $ (sampleSig, "dabc", "12345678", "SEND 11 hello there ") >#> ("", "dabc", "12345678", "ERR AUTH") it "no parameters" $ (sampleSig, "abcd", "12345678", "SEND") >#> ("", "abcd", "12345678", "ERR CMD SYNTAX") @@ -441,13 +440,13 @@ syntaxTests (ATransport t) = do it "bad message body 1" $ (sampleSig, "cdab", "12345678", "SEND 11 hello ") >#> ("", "cdab", "12345678", "ERR CMD SYNTAX") it "bad message body 2" $ (sampleSig, "dabc", "12345678", "SEND hello ") >#> ("", "dabc", "12345678", "ERR CMD SYNTAX") it "bigger body" $ (sampleSig, "abcd", "12345678", "SEND 4 hello ") >#> ("", "abcd", "12345678", "ERR CMD SYNTAX") - describe "PING" do + describe "PING" $ do it "valid syntax" $ ("", "abcd", "", "PING") >#> ("", "abcd", "", "PONG") - describe "broker response not allowed" do + describe "broker response not allowed" $ do it "OK" $ (sampleSig, "bcda", "12345678", "OK") >#> ("", "bcda", "12345678", "ERR CMD PROHIBITED") where noParamsSyntaxTest :: ByteString -> Spec - noParamsSyntaxTest cmd = describe (B.unpack cmd) do + noParamsSyntaxTest cmd = describe (B.unpack cmd) $ do it "valid syntax" $ (sampleSig, "abcd", "12345678", cmd) >#> ("", "abcd", "12345678", "ERR AUTH") it "wrong terminator" $ (sampleSig, "bcda", "12345678", cmd <> "=") >#> ("", "bcda", "12345678", "ERR CMD SYNTAX") it "no signature" $ ("", "cdab", "12345678", cmd) >#> ("", "cdab", "12345678", "ERR CMD NO_AUTH")