asakul
/
libatrade
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Updated to lts-12.9

master
Denis Tereshkin 7 years ago
parent
3227427ef1
commit
ca99468713
10 changed files with 78 additions and 78 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 6
      libatrade.cabal
  2. 4
      src/ATrade/Broker/Client.hs
  3. 4
      src/ATrade/Price.hs
  4. 2
      stack.yaml
  5. 14
      test/ArbitraryInstances.hs
  6. 65
      test/TestBrokerServer.hs
  7. 16
      test/TestQuoteSourceClient.hs
  8. 14
      test/TestQuoteSourceServer.hs
  9. 25
      test/TestTypes.hs
  10. 6
      test/TestZMQTradeSink.hs

6
libatrade.cabal
Unescape View File

@ -1,5 +1,5 @@
name: libatrade name: libatrade
version: 0.5.0.0 version: 0.7.0.0
synopsis: ATrade infrastructure core library synopsis: ATrade infrastructure core library
description: Please see README.md description: Please see README.md
homepage: https://github.com/asakul/libatrade.git homepage: https://github.com/asakul/libatrade.git
@ -7,7 +7,7 @@ license: BSD3
license-file: LICENSE license-file: LICENSE
author: Denis Tereshkin author: Denis Tereshkin
maintainer: denis@kasan.ws maintainer: denis@kasan.ws
copyright: 2016 Denis Tereshkin copyright: 2018 Denis Tereshkin
category: Trading category: Trading
build-type: Simple build-type: Simple
-- extra-source-files: -- extra-source-files:
@ -90,7 +90,7 @@ test-suite libatrade-test
, monad-loops , monad-loops
, uuid , uuid
, stm , stm
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wincomplete-patterns ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wincomplete-patterns -Wno-orphans
default-language: Haskell2010 default-language: Haskell2010
other-modules: ArbitraryInstances other-modules: ArbitraryInstances
, MockBroker , MockBroker

4
src/ATrade/Broker/Client.hs
Unescape View File

@ -64,11 +64,11 @@ brokerClientThread socketIdentity ctx ep cmd resp comp killMv secParams = finall
case cspServerCertificate secParams of case cspServerCertificate secParams of
Just serverCert -> zapSetServerCertificate serverCert sock Just serverCert -> zapSetServerCertificate serverCert sock
Nothing -> return () Nothing -> return ()
connect sock $ T.unpack ep connect sock $ T.unpack ep
debugM "Broker.Client" $ "Connected" debugM "Broker.Client" $ "Connected"
isTimeout <- newIORef False isTimeout <- newIORef False
whileM_ (andM [isNothing <$> tryReadMVar killMv, (== False) <$> readIORef isTimeout]) $ do whileM_ (andM [isNothing <$> tryReadMVar killMv, (== False) <$> readIORef isTimeout]) $ do
request <- takeMVar cmd request <- takeMVar cmd
send sock [] (BL.toStrict $ encode request) send sock [] (BL.toStrict $ encode request)

4
src/ATrade/Price.hs
Unescape View File

@ -17,16 +17,12 @@ import Data.Ratio
import Data.Aeson import Data.Aeson
import Data.Scientific import Data.Scientific
import qualified Data.Text as T
import Text.Printf import Text.Printf
data Price = Price { data Price = Price {
priceQuants :: !Int64 priceQuants :: !Int64
} deriving (Eq, Ord) } deriving (Eq, Ord)
giga :: Int64
giga = 1000000000
mega :: Int64 mega :: Int64
mega = 1000000 mega = 1000000

2
stack.yaml
Unescape View File

@ -15,7 +15,7 @@
# resolver: # resolver:
# name: custom-snapshot # name: custom-snapshot
# location: "./custom-snapshot.yaml" # location: "./custom-snapshot.yaml"
resolver: lts-11.9 resolver: lts-12.9
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below. # Various formats can be used as shown in the example below.

14
test/ArbitraryInstances.hs
Unescape View File

@ -5,20 +5,17 @@ module ArbitraryInstances (
) where ) where
import Test.Tasty
import Test.Tasty.SmallCheck as SC
import Test.Tasty.QuickCheck as QC import Test.Tasty.QuickCheck as QC
import Test.QuickCheck.Instances hiding (Text) import Test.QuickCheck.Instances ()
import ATrade.Types import ATrade.Types
import ATrade.Price as P import ATrade.Price as P
import ATrade.Broker.Protocol import ATrade.Broker.Protocol
import Data.Int
import Data.Scientific
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Calendar import Data.Time.Calendar
notTooBig :: (Num a, Ord a) => a -> Bool
notTooBig x = abs x < 100000000 notTooBig x = abs x < 100000000
instance Arbitrary Tick where instance Arbitrary Tick where
@ -79,6 +76,7 @@ instance Arbitrary Order where
instance Arbitrary Trade where instance Arbitrary Trade where
arbitrary = Trade <$> arbitrary = Trade <$>
arbitrary <*>
arbitrary <*> arbitrary <*>
arbitrary <*> arbitrary <*>
arbitrary <*> arbitrary <*>
@ -103,9 +101,9 @@ instance Arbitrary Notification where
instance Arbitrary BrokerServerRequest where instance Arbitrary BrokerServerRequest where
arbitrary = do arbitrary = do
t <- choose (1, 3) :: Gen Int t <- choose (1, 3) :: Gen Int
if | t == 1 -> RequestSubmitOrder <$> arbitrary <*> arbitrary if | t == 1 -> RequestSubmitOrder <$> arbitrary <*> arbitrary <*> arbitrary
| t == 2 -> RequestCancelOrder <$> arbitrary <*> arbitrary | t == 2 -> RequestCancelOrder <$> arbitrary <*> arbitrary <*> arbitrary
| t == 3 -> RequestNotifications <$> arbitrary | t == 3 -> RequestNotifications <$> arbitrary <*> arbitrary
instance Arbitrary BrokerServerResponse where instance Arbitrary BrokerServerResponse where
arbitrary = do arbitrary = do

65
test/TestBrokerServer.hs
Unescape View File

@ -5,8 +5,6 @@ module TestBrokerServer (
) where ) where
import Test.Tasty import Test.Tasty
import Test.Tasty.SmallCheck as SC
import Test.Tasty.QuickCheck as QC
import Test.Tasty.HUnit import Test.Tasty.HUnit
import ATrade.Types import ATrade.Types
@ -14,26 +12,19 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import ATrade.Broker.Server import ATrade.Broker.Server
import ATrade.Broker.Protocol import ATrade.Broker.Protocol
import ATrade.Util
import qualified Data.Text as T import qualified Data.Text as T
import Control.Monad
import Control.Monad.Loops
import Control.Concurrent.MVar
import Control.Concurrent.BoundedChan
import Control.Concurrent hiding (writeChan) import Control.Concurrent hiding (writeChan)
import Control.Exception import Control.Exception
import System.ZMQ4 import System.ZMQ4
import System.ZMQ4.ZAP
import Data.Aeson import Data.Aeson
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Calendar import Data.Time.Calendar
import Data.Maybe
import qualified Data.List as L
import Data.IORef import Data.IORef
import Data.UUID as U import Data.UUID as U
import Data.UUID.V4 as UV4 import Data.UUID.V4 as UV4
import MockBroker import MockBroker
unitTests :: TestTree
unitTests = testGroup "Broker.Server" [testBrokerServerStartStop unitTests = testGroup "Broker.Server" [testBrokerServerStartStop
, testBrokerServerSubmitOrder , testBrokerServerSubmitOrder
, testBrokerServerSubmitOrderToUnknownAccount , testBrokerServerSubmitOrderToUnknownAccount
@ -48,18 +39,21 @@ unitTests = testGroup "Broker.Server" [testBrokerServerStartStop
-- Few helpers -- Few helpers
-- --
makeEndpoint :: IO T.Text
makeEndpoint = do makeEndpoint = do
uid <- toText <$> UV4.nextRandom uid <- toText <$> UV4.nextRandom
return $ "inproc://brokerserver" `T.append` uid return $ "inproc://brokerserver" `T.append` uid
connectAndSendOrder :: (Sender a) => (String -> IO ()) -> Socket a -> Order -> T.Text -> IO ()
connectAndSendOrder step sock order ep = do connectAndSendOrder step sock order ep = do
step "Connecting" step "Connecting"
connect sock (T.unpack ep) connect sock (T.unpack ep)
step "Sending request" step "Sending request"
send sock [] (BL.toStrict . encode $ RequestSubmitOrder 1 order) send sock [] (BL.toStrict . encode $ RequestSubmitOrder 1 "identity" order)
threadDelay 10000 threadDelay 10000
defaultOrder :: Order
defaultOrder = mkOrder { defaultOrder = mkOrder {
orderAccountId = "demo", orderAccountId = "demo",
orderSecurity = "FOO", orderSecurity = "FOO",
@ -80,16 +74,18 @@ makeTestTradeSink = do
-- Tests -- Tests
-- --
testBrokerServerStartStop :: TestTree
testBrokerServerStartStop = testCase "Broker Server starts and stops" $ withContext (\ctx -> do testBrokerServerStartStop = testCase "Broker Server starts and stops" $ withContext (\ctx -> do
ep <- toText <$> UV4.nextRandom ep <- toText <$> UV4.nextRandom
broS <- startBrokerServer [] ctx ("inproc://brokerserver" `T.append` ep) [] defaultServerSecurityParams broS <- startBrokerServer [] ctx ("inproc://brokerserver" `T.append` ep) [] defaultServerSecurityParams
stopBrokerServer broS) stopBrokerServer broS)
testBrokerServerSubmitOrder :: TestTree
testBrokerServerSubmitOrder = testCaseSteps "Broker Server submits order" $ \step -> withContext (\ctx -> do testBrokerServerSubmitOrder = testCaseSteps "Broker Server submits order" $ \step -> withContext (\ctx -> do
step "Setup" step "Setup"
(mockBroker, broState) <- mkMockBroker ["demo"] (mockBroker, broState) <- mkMockBroker ["demo"]
ep <- makeEndpoint ep <- makeEndpoint
bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\broS -> do bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\_ -> do
withSocket ctx Req (\sock -> do withSocket ctx Req (\sock -> do
connectAndSendOrder step sock defaultOrder ep connectAndSendOrder step sock defaultOrder ep
@ -106,12 +102,13 @@ testBrokerServerSubmitOrder = testCaseSteps "Broker Server submits order" $ \ste
))) )))
testBrokerServerSubmitOrderToUnknownAccount :: TestTree
testBrokerServerSubmitOrderToUnknownAccount = testCaseSteps "Broker Server returns error if account is unknown" $ testBrokerServerSubmitOrderToUnknownAccount = testCaseSteps "Broker Server returns error if account is unknown" $
\step -> withContext (\ctx -> do \step -> withContext (\ctx -> do
step "Setup" step "Setup"
ep <- makeEndpoint ep <- makeEndpoint
(mockBroker, broState) <- mkMockBroker ["demo"] (mockBroker, _) <- mkMockBroker ["demo"]
bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\broS -> bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\_ ->
withSocket ctx Req (\sock -> do withSocket ctx Req (\sock -> do
connectAndSendOrder step sock (defaultOrder { orderAccountId = "foobar" }) ep connectAndSendOrder step sock (defaultOrder { orderAccountId = "foobar" }) ep
@ -124,18 +121,19 @@ testBrokerServerSubmitOrderToUnknownAccount = testCaseSteps "Broker Server retur
))) )))
testBrokerServerCancelOrder :: TestTree
testBrokerServerCancelOrder = testCaseSteps "Broker Server: submitted order cancellation" $ testBrokerServerCancelOrder = testCaseSteps "Broker Server: submitted order cancellation" $
\step -> withContext (\ctx -> do \step -> withContext (\ctx -> do
step "Setup" step "Setup"
ep <- makeEndpoint ep <- makeEndpoint
(mockBroker, broState) <- mkMockBroker ["demo"] (mockBroker, broState) <- mkMockBroker ["demo"]
bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\broS -> bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\_ ->
withSocket ctx Req (\sock -> do withSocket ctx Req (\sock -> do
connectAndSendOrder step sock defaultOrder ep connectAndSendOrder step sock defaultOrder ep
(Just (ResponseOrderSubmitted orderId)) <- decode . BL.fromStrict <$> receive sock (Just (ResponseOrderSubmitted orderId)) <- decode . BL.fromStrict <$> receive sock
step "Sending order cancellation request" step "Sending order cancellation request"
send sock [] (BL.toStrict . encode $ RequestCancelOrder 2 orderId) send sock [] (BL.toStrict . encode $ RequestCancelOrder 2 "identity" orderId)
threadDelay 10000 threadDelay 10000
step "Checking that order is cancelled in BrokerInterface" step "Checking that order is cancelled in BrokerInterface"
@ -150,18 +148,19 @@ testBrokerServerCancelOrder = testCaseSteps "Broker Server: submitted order canc
Nothing -> assertFailure "Invalid response" Nothing -> assertFailure "Invalid response"
))) )))
testBrokerServerCancelUnknownOrder :: TestTree
testBrokerServerCancelUnknownOrder = testCaseSteps "Broker Server: order cancellation: error if order is unknown" $ testBrokerServerCancelUnknownOrder = testCaseSteps "Broker Server: order cancellation: error if order is unknown" $
\step -> withContext (\ctx -> do \step -> withContext (\ctx -> do
step "Setup" step "Setup"
ep <- makeEndpoint ep <- makeEndpoint
(mockBroker, broState) <- mkMockBroker ["demo"] (mockBroker, _) <- mkMockBroker ["demo"]
bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\broS -> bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\_ ->
withSocket ctx Req (\sock -> do withSocket ctx Req (\sock -> do
connectAndSendOrder step sock defaultOrder ep connectAndSendOrder step sock defaultOrder ep
receive sock receive sock
step "Sending order cancellation request" step "Sending order cancellation request"
send sock [] (BL.toStrict . encode $ RequestCancelOrder 2 100) send sock [] (BL.toStrict . encode $ RequestCancelOrder 2 "identity" 100)
threadDelay 10000 threadDelay 10000
step "Reading response" step "Reading response"
@ -172,18 +171,19 @@ testBrokerServerCancelUnknownOrder = testCaseSteps "Broker Server: order cancell
Nothing -> assertFailure "Invalid response" Nothing -> assertFailure "Invalid response"
))) )))
testBrokerServerCorruptedPacket :: TestTree
testBrokerServerCorruptedPacket = testCaseSteps "Broker Server: corrupted packet" $ testBrokerServerCorruptedPacket = testCaseSteps "Broker Server: corrupted packet" $
\step -> withContext (\ctx -> do \step -> withContext (\ctx -> do
step "Setup" step "Setup"
ep <- makeEndpoint ep <- makeEndpoint
(mockBroker, broState) <- mkMockBroker ["demo"] (mockBroker, _) <- mkMockBroker ["demo"]
bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\broS -> bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\_ ->
withSocket ctx Req (\sock -> do withSocket ctx Req (\sock -> do
step "Connecting" step "Connecting"
connect sock (T.unpack ep) connect sock (T.unpack ep)
step "Sending request" step "Sending request"
send sock [] (corrupt . BL.toStrict . encode $ RequestSubmitOrder 1 defaultOrder) send sock [] (corrupt . BL.toStrict . encode $ RequestSubmitOrder 1 "identity" defaultOrder)
threadDelay 10000 threadDelay 10000
step "Reading response" step "Reading response"
@ -196,12 +196,13 @@ testBrokerServerCorruptedPacket = testCaseSteps "Broker Server: corrupted packet
where where
corrupt = B.drop 5 corrupt = B.drop 5
testBrokerServerGetNotifications :: TestTree
testBrokerServerGetNotifications = testCaseSteps "Broker Server: notifications request" $ testBrokerServerGetNotifications = testCaseSteps "Broker Server: notifications request" $
\step -> withContext (\ctx -> do \step -> withContext (\ctx -> do
step "Setup" step "Setup"
ep <- makeEndpoint ep <- makeEndpoint
(mockBroker, broState) <- mkMockBroker ["demo"] (mockBroker, broState) <- mkMockBroker ["demo"]
bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\broS -> bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\_ ->
withSocket ctx Req (\sock -> do withSocket ctx Req (\sock -> do
-- We have to actually submit order, or else server won't know that we should -- We have to actually submit order, or else server won't know that we should
-- be notified about this order -- be notified about this order
@ -221,11 +222,12 @@ testBrokerServerGetNotifications = testCaseSteps "Broker Server: notifications r
tradeAccount = "demo", tradeAccount = "demo",
tradeSecurity = "FOO", tradeSecurity = "FOO",
tradeTimestamp = UTCTime (fromGregorian 2016 9 28) 16000, tradeTimestamp = UTCTime (fromGregorian 2016 9 28) 16000,
tradeCommission = 0,
tradeSignalId = SignalId "Foo" "bar" "baz" } tradeSignalId = SignalId "Foo" "bar" "baz" }
cb (TradeNotification trade) cb (TradeNotification trade)
step "Sending notifications request" step "Sending notifications request"
send sock [] (BL.toStrict . encode $ RequestNotifications 2) send sock [] (BL.toStrict . encode $ RequestNotifications 2 "identity")
threadDelay 10000 threadDelay 10000
-- We should obtain 3 notifications: -- We should obtain 3 notifications:
@ -246,25 +248,26 @@ testBrokerServerGetNotifications = testCaseSteps "Broker Server: notifications r
Nothing -> assertFailure "Invalid response" Nothing -> assertFailure "Invalid response"
step "Sending second notifications request" step "Sending second notifications request"
send sock [] (BL.toStrict . encode $ RequestNotifications 3) send sock [] (BL.toStrict . encode $ RequestNotifications 3 "identity")
threadDelay 10000 threadDelay 10000
step "Reading response" step "Reading response"
resp <- decode . BL.fromStrict <$> receive sock resp' <- decode . BL.fromStrict <$> receive sock
case resp of case resp' of
Just (ResponseNotifications ns) -> do Just (ResponseNotifications ns) -> do
0 @=? length ns 0 @=? length ns
Just _ -> assertFailure "Invalid response" Just _ -> assertFailure "Invalid response"
Nothing -> assertFailure "Invalid response" Nothing -> assertFailure "Invalid response"
))) )))
testBrokerServerDuplicateRequest :: TestTree
testBrokerServerDuplicateRequest = testCaseSteps "Broker Server: duplicate request" $ \step -> withContext (\ctx -> do testBrokerServerDuplicateRequest = testCaseSteps "Broker Server: duplicate request" $ \step -> withContext (\ctx -> do
putStrLn "epsilon" putStrLn "epsilon"
step "Setup" step "Setup"
(mockBroker, broState) <- mkMockBroker ["demo"] (mockBroker, broState) <- mkMockBroker ["demo"]
ep <- makeEndpoint ep <- makeEndpoint
putStrLn "delta" putStrLn "delta"
bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\broS -> do bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\_ -> do
putStrLn "gamma" putStrLn "gamma"
withSocket ctx Req (\sock -> do withSocket ctx Req (\sock -> do
putStrLn "alpha" putStrLn "alpha"
@ -275,7 +278,7 @@ testBrokerServerDuplicateRequest = testCaseSteps "Broker Server: duplicate reque
(Just (ResponseOrderSubmitted orderId)) <- decode . BL.fromStrict <$> receive sock (Just (ResponseOrderSubmitted orderId)) <- decode . BL.fromStrict <$> receive sock
step "Sending duplicate request (with same sequence number)" step "Sending duplicate request (with same sequence number)"
send sock [] (BL.toStrict . encode $ RequestSubmitOrder 1 defaultOrder) send sock [] (BL.toStrict . encode $ RequestSubmitOrder 1 "identity" defaultOrder)
threadDelay 10000 threadDelay 10000
step "Checking that only one order is submitted" step "Checking that only one order is submitted"
@ -291,12 +294,13 @@ testBrokerServerDuplicateRequest = testCaseSteps "Broker Server: duplicate reque
))) )))
testBrokerServerTradeSink :: TestTree
testBrokerServerTradeSink = testCaseSteps "Broker Server: sends trades to trade sink" $ \step -> withContext (\ctx -> do testBrokerServerTradeSink = testCaseSteps "Broker Server: sends trades to trade sink" $ \step -> withContext (\ctx -> do
step "Setup" step "Setup"
(mockBroker, broState) <- mkMockBroker ["demo"] (mockBroker, broState) <- mkMockBroker ["demo"]
ep <- makeEndpoint ep <- makeEndpoint
(tradeRef, sink) <- makeTestTradeSink (tradeRef, sink) <- makeTestTradeSink
bracket (startBrokerServer [mockBroker] ctx ep [sink] defaultServerSecurityParams) stopBrokerServer (\broS -> do bracket (startBrokerServer [mockBroker] ctx ep [sink] defaultServerSecurityParams) stopBrokerServer (\_ -> do
withSocket ctx Req (\sock -> do withSocket ctx Req (\sock -> do
step "Connecting" step "Connecting"
connectAndSendOrder step sock defaultOrder ep connectAndSendOrder step sock defaultOrder ep
@ -313,6 +317,7 @@ testBrokerServerTradeSink = testCaseSteps "Broker Server: sends trades to trade
tradeAccount = "demo", tradeAccount = "demo",
tradeSecurity = "FOO", tradeSecurity = "FOO",
tradeTimestamp = UTCTime (fromGregorian 2016 9 28) 16000, tradeTimestamp = UTCTime (fromGregorian 2016 9 28) 16000,
tradeCommission = 0,
tradeSignalId = SignalId "Foo" "bar" "baz" } tradeSignalId = SignalId "Foo" "bar" "baz" }
cb (TradeNotification trade) cb (TradeNotification trade)

16
test/TestQuoteSourceClient.hs
Unescape View File

@ -5,47 +5,45 @@ module TestQuoteSourceClient (
) where ) where
import Test.Tasty import Test.Tasty
import Test.Tasty.SmallCheck as SC
import Test.Tasty.QuickCheck as QC
import Test.Tasty.HUnit import Test.Tasty.HUnit
import ATrade.Types import ATrade.Types
import ATrade.QuoteSource.Server import ATrade.QuoteSource.Server
import ATrade.QuoteSource.Client import ATrade.QuoteSource.Client
import Control.Monad import Control.Monad
import Control.Monad.Loops
import Control.Concurrent.MVar
import Control.Concurrent.BoundedChan import Control.Concurrent.BoundedChan
import Control.Concurrent hiding (writeChan, readChan) import Control.Concurrent hiding (writeChan, readChan)
import Control.Exception import Control.Exception
import System.ZMQ4 import System.ZMQ4
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Calendar import Data.Time.Calendar
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T import qualified Data.Text as T
import Data.Maybe
import Data.UUID as U import Data.UUID as U
import Data.UUID.V4 as UV4 import Data.UUID.V4 as UV4
makeEndpoint :: IO T.Text
makeEndpoint = do makeEndpoint = do
uid <- toText <$> UV4.nextRandom uid <- toText <$> UV4.nextRandom
return $ "inproc://server" `T.append` uid return $ "inproc://server" `T.append` uid
unitTests :: TestTree
unitTests = testGroup "QuoteSource.Client" [testStartStop, testTickStream] unitTests = testGroup "QuoteSource.Client" [testStartStop, testTickStream]
testStartStop :: TestTree
testStartStop = testCase "QuoteSource client connects and disconnects" $ withContext (\ctx -> do testStartStop = testCase "QuoteSource client connects and disconnects" $ withContext (\ctx -> do
ep <- makeEndpoint ep <- makeEndpoint
chan <- newBoundedChan 1000 chan <- newBoundedChan 1000
clientChan <- newBoundedChan 1000 clientChan <- newBoundedChan 1000
bracket (startQuoteSourceServer chan ctx ep) stopQuoteSourceServer (\qs -> bracket (startQuoteSourceServer chan ctx ep Nothing) stopQuoteSourceServer (\_ ->
bracket (startQuoteSourceClient clientChan [] ctx ep) stopQuoteSourceClient (const yield))) bracket (startQuoteSourceClient clientChan [] ctx ep) stopQuoteSourceClient (const yield)))
testTickStream :: TestTree
testTickStream = testCase "QuoteSource clients receives ticks" $ withContext (\ctx -> do testTickStream = testCase "QuoteSource clients receives ticks" $ withContext (\ctx -> do
ep <- makeEndpoint ep <- makeEndpoint
chan <- newBoundedChan 1000 chan <- newBoundedChan 1000
clientChan <- newBoundedChan 1000 clientChan <- newBoundedChan 1000
bracket (startQuoteSourceServer chan ctx ep) stopQuoteSourceServer (\qs -> bracket (startQuoteSourceServer chan ctx ep Nothing) stopQuoteSourceServer (\_ ->
bracket (startQuoteSourceClient clientChan ["FOOBAR"] ctx ep) stopQuoteSourceClient (\qc -> do bracket (startQuoteSourceClient clientChan ["FOOBAR"] ctx ep) stopQuoteSourceClient (\_ -> do
let tick = Tick { let tick = Tick {
security = "FOOBAR", security = "FOOBAR",
datatype = LastTradePrice, datatype = LastTradePrice,

14
test/TestQuoteSourceServer.hs
Unescape View File

@ -5,34 +5,30 @@ module TestQuoteSourceServer (
) where ) where
import Test.Tasty import Test.Tasty
import Test.Tasty.SmallCheck as SC
import Test.Tasty.QuickCheck as QC
import Test.Tasty.HUnit import Test.Tasty.HUnit
import ATrade.Types import ATrade.Types
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import ATrade.QuoteSource.Server import ATrade.QuoteSource.Server
import Control.Monad
import Control.Monad.Loops
import Control.Concurrent.MVar
import Control.Concurrent hiding (writeChan)
import Control.Concurrent.BoundedChan import Control.Concurrent.BoundedChan
import Control.Exception import Control.Exception
import System.ZMQ4 import System.ZMQ4
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Calendar import Data.Time.Calendar
import Data.Maybe
unitTests :: TestTree
unitTests = testGroup "QuoteSource.Server" [testStartStop, testTickStream] unitTests = testGroup "QuoteSource.Server" [testStartStop, testTickStream]
testStartStop :: TestTree
testStartStop = testCase "QuoteSource Server starts and stops" $ withContext (\ctx -> do testStartStop = testCase "QuoteSource Server starts and stops" $ withContext (\ctx -> do
chan <- newBoundedChan 1000 chan <- newBoundedChan 1000
qss <- startQuoteSourceServer chan ctx "inproc://quotesource-server" qss <- startQuoteSourceServer chan ctx "inproc://quotesource-server" Nothing
stopQuoteSourceServer qss) stopQuoteSourceServer qss)
testTickStream :: TestTree
testTickStream = testCase "QuoteSource Server sends ticks" $ withContext (\ctx -> do testTickStream = testCase "QuoteSource Server sends ticks" $ withContext (\ctx -> do
chan <- newBoundedChan 1000 chan <- newBoundedChan 1000
bracket (startQuoteSourceServer chan ctx "inproc://quotesource-server") stopQuoteSourceServer (\qs -> bracket (startQuoteSourceServer chan ctx "inproc://quotesource-server" Nothing) stopQuoteSourceServer (\_ ->
withSocket ctx Sub (\s -> do withSocket ctx Sub (\s -> do
connect s "inproc://quotesource-server" connect s "inproc://quotesource-server"
subscribe s "FOOBAR" subscribe s "FOOBAR"

25
test/TestTypes.hs
Unescape View File

@ -6,23 +6,16 @@ module TestTypes (
) where ) where
import Test.Tasty import Test.Tasty
import Test.Tasty.SmallCheck as SC
import Test.Tasty.QuickCheck as QC import Test.Tasty.QuickCheck as QC
import Test.Tasty.HUnit
import ATrade.Types import ATrade.Types
import ATrade.Price as P import ATrade.Price as P
import ArbitraryInstances
import ArbitraryInstances ()
import Data.Aeson import Data.Aeson
import Data.Aeson.Types
import Data.Scientific
import Data.Text
import Data.Time.Calendar
import Data.Time.Clock
import Data.Tuple.Select
import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy as B
properties :: TestTree
properties = testGroup "Types" [ properties = testGroup "Types" [
testTickSerialization testTickSerialization
, testTickBodySerialization , testTickBodySerialization
@ -40,12 +33,14 @@ properties = testGroup "Types" [
, testPriceSubtraction , testPriceSubtraction
] ]
testTickSerialization :: TestTree
testTickSerialization = QC.testProperty "Deserialize serialized tick" testTickSerialization = QC.testProperty "Deserialize serialized tick"
(\tick -> case (deserializeTick . serializeTick) tick of (\tick -> case (deserializeTick . serializeTick) tick of
Just t -> tick == t Just t -> tick == t
Nothing -> False) Nothing -> False)
-- Adjust arbitrary instances of ticks, because body doesn't store security name -- Adjust arbitrary instances of ticks, because body doesn't store security name
testTickBodySerialization :: TestTree
testTickBodySerialization = QC.testProperty "Deserialize serialized bunch of tick" $ testTickBodySerialization = QC.testProperty "Deserialize serialized bunch of tick" $
QC.forAll (arbitrary >>= (\t -> return t { security = "" })) (\tick1 -> QC.forAll (arbitrary >>= (\t -> return t { security = "" })) (\tick1 ->
QC.forAll (arbitrary >>= (\t -> return t { security = "" })) (\tick2 -> QC.forAll (arbitrary >>= (\t -> return t { security = "" })) (\tick2 ->
@ -57,55 +52,67 @@ testTickBodySerialization = QC.testProperty "Deserialize serialized bunch of tic
where where
serialized t1 t2 = serializeTickBody t1 `B.append` serializeTickBody t2 serialized t1 t2 = serializeTickBody t1 `B.append` serializeTickBody t2
testSignalIdSerialization :: TestTree
testSignalIdSerialization = QC.testProperty "Deserialize serialized SignalId" testSignalIdSerialization = QC.testProperty "Deserialize serialized SignalId"
(\sid -> case (decode . encode $ sid :: Maybe SignalId) of (\sid -> case (decode . encode $ sid :: Maybe SignalId) of
Just s -> s == sid Just s -> s == sid
Nothing -> False) Nothing -> False)
testOrderPriceSerialization :: TestTree
testOrderPriceSerialization = QC.testProperty "Deserialize serialized OrderPrice" testOrderPriceSerialization = QC.testProperty "Deserialize serialized OrderPrice"
(\v -> case (decode . encode $ v :: Maybe OrderPrice) of (\v -> case (decode . encode $ v :: Maybe OrderPrice) of
Just s -> s == v Just s -> s == v
Nothing -> False) Nothing -> False)
testOperationSerialization :: TestTree
testOperationSerialization = QC.testProperty "Deserialize serialized Operation" testOperationSerialization = QC.testProperty "Deserialize serialized Operation"
(\v -> case (decode . encode $ v :: Maybe Operation) of (\v -> case (decode . encode $ v :: Maybe Operation) of
Just s -> s == v Just s -> s == v
Nothing -> False) Nothing -> False)
testOrderStateSerialization :: TestTree
testOrderStateSerialization = QC.testProperty "Deserialize serialized OrderState" testOrderStateSerialization = QC.testProperty "Deserialize serialized OrderState"
(\v -> case (decode . encode $ v :: Maybe OrderState) of (\v -> case (decode . encode $ v :: Maybe OrderState) of
Just s -> s == v Just s -> s == v
Nothing -> False) Nothing -> False)
testOrderSerialization :: TestTree
testOrderSerialization = QC.testProperty "Deserialize serialized Order" testOrderSerialization = QC.testProperty "Deserialize serialized Order"
(\v -> case (decode . encode $ v :: Maybe Order) of (\v -> case (decode . encode $ v :: Maybe Order) of
Just s -> s == v Just s -> s == v
Nothing -> False) Nothing -> False)
testTradeSerialization :: TestTree
testTradeSerialization = QC.testProperty "Deserialize serialized Trade" testTradeSerialization = QC.testProperty "Deserialize serialized Trade"
(\v -> case (decode . encode $ v :: Maybe Trade) of (\v -> case (decode . encode $ v :: Maybe Trade) of
Just s -> s == v Just s -> s == v
Nothing -> False) Nothing -> False)
testPrice1 :: TestTree
testPrice1 = QC.testProperty "fromDouble . toDouble $ Price" testPrice1 = QC.testProperty "fromDouble . toDouble $ Price"
(\p -> let newp = (P.fromDouble . P.toDouble) p in (\p -> let newp = (P.fromDouble . P.toDouble) p in
(abs (priceQuants newp - priceQuants p) < 1000)) (abs (priceQuants newp - priceQuants p) < 1000))
testPrice2 :: TestTree
testPrice2 = QC.testProperty "toDouble . fromDouble $ Price" $ testPrice2 = QC.testProperty "toDouble . fromDouble $ Price" $
QC.forAll (arbitrary `suchThat` (< 1000000000)) (\d -> let newd = (P.toDouble . P.fromDouble) d in QC.forAll (arbitrary `suchThat` (< 1000000000)) (\d -> let newd = (P.toDouble . P.fromDouble) d in
(abs (newd - d) < 0.000001)) (abs (newd - d) < 0.000001))
testPriceDecompose :: TestTree
testPriceDecompose = QC.testProperty "Price decompose" testPriceDecompose = QC.testProperty "Price decompose"
(\p -> let (i, f) = decompose p in (\p -> let (i, f) = decompose p in
i * 1000000 + (fromInteger . fromIntegral) f == priceQuants p) i * 1000000 + (fromInteger . fromIntegral) f == priceQuants p)
testPriceAddition :: TestTree
testPriceAddition = QC.testProperty "Price addition" testPriceAddition = QC.testProperty "Price addition"
(\(p1, p2) -> abs (toDouble p1 + toDouble p2 - toDouble (p1 + p2)) < 0.00001) (\(p1, p2) -> abs (toDouble p1 + toDouble p2 - toDouble (p1 + p2)) < 0.00001)
testPriceMultiplication :: TestTree
testPriceMultiplication = QC.testProperty "Price multiplication" $ testPriceMultiplication = QC.testProperty "Price multiplication" $
QC.forAll (arbitrary `suchThat` (\(p1, p2) -> p1 < 100000 && p2 < 100000)) QC.forAll (arbitrary `suchThat` (\(p1, p2) -> p1 < 100000 && p2 < 100000))
(\(p1, p2) -> abs (toDouble p1 + toDouble p2 - toDouble (p1 + p2)) < 0.00001) (\(p1, p2) -> abs (toDouble p1 + toDouble p2 - toDouble (p1 + p2)) < 0.00001)
testPriceSubtraction :: TestTree
testPriceSubtraction = QC.testProperty "Price subtraction" testPriceSubtraction = QC.testProperty "Price subtraction"
(\(p1, p2) -> abs (toDouble p1 - toDouble p2 - toDouble (p1 - p2)) < 0.00001) (\(p1, p2) -> abs (toDouble p1 - toDouble p2 - toDouble (p1 - p2)) < 0.00001)

6
test/TestZMQTradeSink.hs
Unescape View File

@ -5,14 +5,11 @@ module TestZMQTradeSink (
) where ) where
import Test.Tasty import Test.Tasty
import Test.Tasty.SmallCheck as SC
import Test.Tasty.QuickCheck as QC
import Test.Tasty.HUnit import Test.Tasty.HUnit
import ATrade.Types import ATrade.Types
import ATrade.Broker.Protocol import ATrade.Broker.Protocol
import ATrade.Broker.TradeSinks.ZMQTradeSink import ATrade.Broker.TradeSinks.ZMQTradeSink
import Control.Concurrent
import System.ZMQ4 import System.ZMQ4
import Data.Aeson import Data.Aeson
import Data.Time.Calendar import Data.Time.Calendar
@ -20,8 +17,10 @@ import Data.Time.Clock
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
unitTests :: TestTree
unitTests = testGroup "Broker.Server.TradeSinks.ZMQTradeSink" [ testZMQTradeSink ] unitTests = testGroup "Broker.Server.TradeSinks.ZMQTradeSink" [ testZMQTradeSink ]
testZMQTradeSink :: TestTree
testZMQTradeSink = testCase "Test ZMQTradeSink trade serialization" $ testZMQTradeSink = testCase "Test ZMQTradeSink trade serialization" $
withContext (\ctx -> withSocket ctx Rep (\insock -> do withContext (\ctx -> withSocket ctx Rep (\insock -> do
bind insock "inproc://test-sink" bind insock "inproc://test-sink"
@ -43,5 +42,6 @@ testZMQTradeSink = testCase "Test ZMQTradeSink trade serialization" $
tradeAccount = "FOO", tradeAccount = "FOO",
tradeSecurity = "BAR", tradeSecurity = "BAR",
tradeTimestamp = UTCTime (fromGregorian 1970 1 1) 0, tradeTimestamp = UTCTime (fromGregorian 1970 1 1) 0,
tradeCommission = 0,
tradeSignalId = SignalId "foo" "bar" "" } tradeSignalId = SignalId "foo" "bar" "" }

Write Preview
Loading…
Cancel
Save