dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-04-27 02:05:14 +00:00
Code Issues Packages Projects Releases Wiki Activity

downgrade GHC to 8.4.4

Browse Source
This commit is contained in:
Evgeny Poberezkin
2021-11-16 14:36:50 +00:00
parent 227d83d0e7
commit d81d61ec36
22 changed files with 164 additions and 160 deletions
Download Patch File Download Diff File Expand all files Collapse all files
package.yaml
+19 -19
View File
@@ -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:
simplexmq.cabal
+60 -60
View File
@@ -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
src/Simplex/Messaging/Agent.hs
+2 -4
View File
@@ -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
src/Simplex/Messaging/Agent/Client.hs
+4 -5
View File
@@ -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
src/Simplex/Messaging/Agent/Env/SQLite.hs
+5 -6
View File
@@ -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
}
}
src/Simplex/Messaging/Agent/Protocol.hs
+1 -1
View File
@@ -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
src/Simplex/Messaging/Agent/Store.hs
+1
View File
@@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
src/Simplex/Messaging/Agent/Store/SQLite.hs
+2 -3
View File
@@ -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 =
src/Simplex/Messaging/Client.hs
+5 -6
View File
@@ -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,
src/Simplex/Messaging/Crypto.hs
+1 -1
View File
@@ -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
src/Simplex/Messaging/Server.hs
-1
View File
@@ -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
src/Simplex/Messaging/Server/Env/STM.hs
+4 -4
View File
@@ -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
src/Simplex/Messaging/Server/MsgStore/STM.hs
+1 -1
View File
@@ -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
src/Simplex/Messaging/Transport.hs
+3 -3
View File
@@ -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
src/Simplex/Messaging/Util.hs
+10
View File
@@ -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 #-}
stack.yaml
+3 -3
View File
@@ -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
tests/AgentTests.hs
+9 -10
View File
@@ -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
tests/AgentTests/FunctionalAPITests.hs
+1 -1
View File
@@ -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 (..))
tests/AgentTests/SQLiteTests.hs
+15 -16
View File
@@ -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
tests/SMPAgentClient.hs
+2 -4
View File
@@ -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
tests/SMPClient.hs
+8 -3
View File
@@ -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 ()
tests/ServerTests.hs
+8 -9
View File
@@ -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")