diff --git a/src/ATrade/Price.hs b/src/ATrade/Price.hs index 722a556..ae72144 100644 --- a/src/ATrade/Price.hs +++ b/src/ATrade/Price.hs @@ -45,7 +45,9 @@ toDouble :: Price -> Double toDouble p = fromIntegral (priceQuants p) / fromIntegral mega fromDouble :: Double -> Price -fromDouble d = Price { priceQuants = truncate ((d * fromIntegral mega) + 0.5) } +fromDouble d + | d >= 0 = Price { priceQuants = truncate ((d * fromIntegral mega) + 0.5) } + | otherwise = Price { priceQuants = truncate ((d * fromIntegral mega) - 0.5) } toScientific :: Price -> Scientific toScientific p = normalize $ scientific (toInteger $ priceQuants p) (-6) diff --git a/test/TestQuoteSourceClient.hs b/test/TestQuoteSourceClient.hs index 4debb3d..cb484eb 100644 --- a/test/TestQuoteSourceClient.hs +++ b/test/TestQuoteSourceClient.hs @@ -20,6 +20,7 @@ import Data.Time.Clock import Data.UUID as U import Data.UUID.V4 as UV4 import System.ZMQ4 +import System.ZMQ4.ZAP makeEndpoint :: IO T.Text makeEndpoint = do @@ -37,16 +38,16 @@ testStartStop = testCase "QuoteSource client connects and disconnects" $ withCon ep <- makeEndpoint chan <- newBoundedChan 1000 clientChan <- newBoundedChan 1000 - bracket (startQuoteSourceServer chan ctx ep Nothing) stopQuoteSourceServer (\_ -> - bracket (startQuoteSourceClient clientChan [] ctx ep) stopQuoteSourceClient (const yield))) + bracket (startQuoteSourceServer chan ctx ep defaultServerSecurityParams) stopQuoteSourceServer (\_ -> + bracket (startQuoteSourceClient clientChan [] ctx ep defaultClientSecurityParams) stopQuoteSourceClient (const yield))) testTickStream :: TestTree testTickStream = testCase "QuoteSource clients receives ticks" $ withContext (\ctx -> do ep <- makeEndpoint chan <- newBoundedChan 1000 clientChan <- newBoundedChan 1000 - bracket (startQuoteSourceServer chan ctx ep Nothing) stopQuoteSourceServer (\_ -> - bracket (startQuoteSourceClient clientChan ["FOOBAR"] ctx ep) stopQuoteSourceClient (\_ -> do + bracket (startQuoteSourceServer chan ctx ep defaultServerSecurityParams) stopQuoteSourceServer (\_ -> + bracket (startQuoteSourceClient clientChan ["FOOBAR"] ctx ep defaultClientSecurityParams) stopQuoteSourceClient (\_ -> do let tick = Tick { security = "FOOBAR", datatype = LastTradePrice, @@ -62,8 +63,8 @@ testBarStream = testCase "QuoteSource clients receives bars" $ withContext (\ctx ep <- makeEndpoint chan <- newBoundedChan 1000 clientChan <- newBoundedChan 1000 - bracket (startQuoteSourceServer chan ctx ep Nothing) stopQuoteSourceServer (\_ -> - bracket (startQuoteSourceClient clientChan ["FOOBAR"] ctx ep) stopQuoteSourceClient (\_ -> do + bracket (startQuoteSourceServer chan ctx ep defaultServerSecurityParams) stopQuoteSourceServer (\_ -> + bracket (startQuoteSourceClient clientChan ["FOOBAR"] ctx ep defaultClientSecurityParams) stopQuoteSourceClient (\_ -> do let bar = Bar { barSecurity = "FOOBAR", barTimestamp = UTCTime (fromGregorian 2016 9 27) 16000, diff --git a/test/TestQuoteSourceServer.hs b/test/TestQuoteSourceServer.hs index fba8636..b31b813 100644 --- a/test/TestQuoteSourceServer.hs +++ b/test/TestQuoteSourceServer.hs @@ -15,6 +15,7 @@ import qualified Data.ByteString.Lazy as BL import Data.Time.Calendar import Data.Time.Clock import System.ZMQ4 +import System.ZMQ4.ZAP unitTests :: TestTree unitTests = testGroup "QuoteSource.Server" [ @@ -25,13 +26,13 @@ unitTests = testGroup "QuoteSource.Server" [ testStartStop :: TestTree testStartStop = testCase "QuoteSource Server starts and stops" $ withContext (\ctx -> do chan <- newBoundedChan 1000 - qss <- startQuoteSourceServer chan ctx "inproc://quotesource-server" Nothing + qss <- startQuoteSourceServer chan ctx "inproc://quotesource-server" defaultServerSecurityParams stopQuoteSourceServer qss) testTickStream :: TestTree testTickStream = testCase "QuoteSource Server sends ticks" $ withContext (\ctx -> do chan <- newBoundedChan 1000 - bracket (startQuoteSourceServer chan ctx "inproc://quotesource-server" Nothing) stopQuoteSourceServer (\_ -> + bracket (startQuoteSourceServer chan ctx "inproc://quotesource-server" defaultServerSecurityParams) stopQuoteSourceServer (\_ -> withSocket ctx Sub (\s -> do connect s "inproc://quotesource-server" subscribe s "FOOBAR" @@ -51,7 +52,7 @@ testTickStream = testCase "QuoteSource Server sends ticks" $ withContext (\ctx - testBarStream :: TestTree testBarStream = testCase "QuoteSource Server sends bars" $ withContext (\ctx -> do chan <- newBoundedChan 1000 - bracket (startQuoteSourceServer chan ctx "inproc://quotesource-server" Nothing) stopQuoteSourceServer (\_ -> + bracket (startQuoteSourceServer chan ctx "inproc://quotesource-server" defaultServerSecurityParams) stopQuoteSourceServer (\_ -> withSocket ctx Sub (\s -> do connect s "inproc://quotesource-server" subscribe s "FOOBAR" diff --git a/test/TestTypes.hs b/test/TestTypes.hs index 1129ce9..bf62b58 100644 --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -1,21 +1,23 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} module TestTypes ( properties ) where -import Test.Tasty -import Test.Tasty.QuickCheck as QC +import Test.Tasty +import Test.Tasty.QuickCheck as QC -import ATrade.Types -import ATrade.Price as P +import ATrade.Price as P +import ATrade.Types -import ArbitraryInstances () -import Data.Aeson -import qualified Data.ByteString.Lazy as B +import ArbitraryInstances () +import Data.Aeson +import qualified Data.ByteString.Lazy as B -import Debug.Trace +import Debug.Trace properties :: TestTree properties = testGroup "Types" [ @@ -39,18 +41,18 @@ properties = testGroup "Types" [ testTickSerialization :: TestTree testTickSerialization = QC.testProperty "Deserialize serialized tick" (\tick -> case (deserializeTick . serializeTick) tick of - Just t -> tick == t + Just t -> tick == t Nothing -> False) -- Adjust arbitrary instances of ticks, because body doesn't store security name testTickBodySerialization :: TestTree 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 -> case deserializeTickBody (serialized tick1 tick2) of (rest, Just t1) -> case deserializeTickBody rest of (_, Just t2) -> tick1 == t1 && tick2 == t2 - _ -> False + _ -> False _ -> False)) where serialized t1 t2 = serializeTickBody t1 `B.append` serializeTickBody t2 @@ -58,43 +60,43 @@ testTickBodySerialization = QC.testProperty "Deserialize serialized bunch of tic testSignalIdSerialization :: TestTree testSignalIdSerialization = QC.testProperty "Deserialize serialized SignalId" (\sid -> case (decode . encode $ sid :: Maybe SignalId) of - Just s -> s == sid + Just s -> s == sid Nothing -> False) testOrderPriceSerialization :: TestTree testOrderPriceSerialization = QC.testProperty "Deserialize serialized OrderPrice" (\v -> case (decode . encode $ v :: Maybe OrderPrice) of - Just s -> s == v + Just s -> s == v Nothing -> False) testOperationSerialization :: TestTree testOperationSerialization = QC.testProperty "Deserialize serialized Operation" (\v -> case (decode . encode $ v :: Maybe Operation) of - Just s -> s == v + Just s -> s == v Nothing -> False) testOrderStateSerialization :: TestTree testOrderStateSerialization = QC.testProperty "Deserialize serialized OrderState" (\v -> case (decode . encode $ v :: Maybe OrderState) of - Just s -> s == v + Just s -> s == v Nothing -> False) testOrderSerialization :: TestTree testOrderSerialization = QC.testProperty "Deserialize serialized Order" (\v -> case (decode . encode $ v :: Maybe Order) of - Just s -> s == v + Just s -> s == v Nothing -> False) testTradeSerialization :: TestTree testTradeSerialization = QC.testProperty "Deserialize serialized Trade" (\v -> case (decode . encode $ v :: Maybe Trade) of - Just s -> s == v + Just s -> s == v Nothing -> False) testPrice1 :: TestTree -testPrice1 = QC.testProperty "fromDouble . toDouble $ Price" - (\p -> let newp = (P.fromDouble . P.toDouble) p in - (abs (priceQuants newp - priceQuants p) < 1000)) +testPrice1 = QC.testProperty "fromDouble . toDouble $ Price" $ + QC.forAll (arbitrary `suchThat` (\x -> abs x < 100000000)) (\p -> let newp = (P.fromDouble . P.toDouble) p in + (priceQuants newp == priceQuants p)) testPrice2 :: TestTree testPrice2 = QC.testProperty "toDouble . fromDouble $ Price" $ @@ -123,4 +125,4 @@ testBarSerialization :: TestTree testBarSerialization = QC.testProperty "Deserialize serialized bar" (\(tf, bar) -> case deserializeBar (serializeBar tf bar) of Just (tf', bar') -> bar == bar' && tf == tf' - Nothing -> False) + Nothing -> False)