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

Quotesource: support bar transfer

master
Denis Tereshkin 7 years ago
parent
ca99468713
commit
2380a05203
10 changed files with 347 additions and 183 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. 1
      .gitignore
  2. 2
      src/ATrade/Broker/Server.hs
  3. 57
      src/ATrade/QuoteSource/Client.hs
  4. 65
      src/ATrade/QuoteSource/Server.hs
  5. 241
      src/ATrade/Types.hs
  6. 2
      stack.yaml
  7. 33
      test/ArbitraryInstances.hs
  8. 59
      test/TestQuoteSourceClient.hs
  9. 50
      test/TestQuoteSourceServer.hs
  10. 8
      test/TestTypes.hs

1
.gitignore vendored
Unescape View File

@ -1,2 +1,3 @@
.* .*
\#*.*\#

2
src/ATrade/Broker/Server.hs
Unescape View File

@ -118,7 +118,7 @@ tradeSinkHandler c state tradeSinks = unless (null tradeSinks) $
maybeTrade <- tryReadChan chan maybeTrade <- tryReadChan chan
case maybeTrade of case maybeTrade of
Just trade -> mapM_ (\x -> x trade) tradeSinks Just trade -> mapM_ (\x -> x trade) tradeSinks
Nothing -> threadDelay 1000000 Nothing -> threadDelay 100000
where where
wasKilled = isJust <$> (killMvar <$> readIORef state >>= tryReadMVar) wasKilled = isJust <$> (killMvar <$> readIORef state >>= tryReadMVar)

57
src/ATrade/QuoteSource/Client.hs
Unescape View File

@ -1,47 +1,52 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module ATrade.QuoteSource.Client ( module ATrade.QuoteSource.Client (
QuoteData(..),
startQuoteSourceClient, startQuoteSourceClient,
stopQuoteSourceClient stopQuoteSourceClient
) where ) where
import ATrade.Types import ATrade.Types
import Control.Concurrent.BoundedChan import Control.Concurrent hiding (readChan, writeChan,
import Control.Concurrent hiding (readChan, writeChan, writeList2Chan) writeList2Chan)
import Control.Concurrent.MVar import Control.Concurrent.BoundedChan
import Control.Monad import Control.Concurrent.MVar
import Control.Monad.Loops import Control.Exception
import Control.Exception import Control.Monad
import Data.List.NonEmpty import Control.Monad.Loops
import Data.Maybe import qualified Data.ByteString.Char8 as B8
import qualified Data.Text as T import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy as BL import Data.IORef
import qualified Data.ByteString.Char8 as B8 import qualified Data.List as L
import qualified Data.List as L import Data.List.NonEmpty
import Data.Text.Encoding import Data.Maybe
import Data.Time.Clock import qualified Data.Text as T
import Data.IORef import Data.Text.Encoding
import System.ZMQ4 import Data.Time.Clock
import System.Log.Logger import System.Log.Logger
import System.ZMQ4
import Safe import Safe
data QuoteSourceClientHandle = QuoteSourceClientHandle { data QuoteSourceClientHandle = QuoteSourceClientHandle {
tid :: ThreadId, tid :: ThreadId,
completionMvar :: MVar (), completionMvar :: MVar (),
killMVar :: MVar () killMVar :: MVar ()
} }
deserializeTicks :: [BL.ByteString] -> [Tick] data QuoteData = QDTick Tick | QDBar (BarTimeframe, Bar)
deriving (Show, Eq)
deserializeTicks :: [BL.ByteString] -> [QuoteData]
deserializeTicks (secname:raw:_) = deserializeWithName (decodeUtf8 . BL.toStrict $ secname) raw deserializeTicks (secname:raw:_) = deserializeWithName (decodeUtf8 . BL.toStrict $ secname) raw
where where
deserializeWithName secNameT raw = case deserializeTickBody raw of deserializeWithName secNameT raw = case deserializeTickBody raw of
(rest, Just tick) -> tick { security = secNameT } : deserializeWithName secNameT rest (rest, Just tick) -> QDTick (tick { security = secNameT }) : deserializeWithName secNameT rest
_ -> [] _ -> []
deserializeTicks _ = [] deserializeTicks _ = []
startQuoteSourceClient :: BoundedChan Tick -> [T.Text] -> Context -> T.Text -> IO QuoteSourceClientHandle startQuoteSourceClient :: BoundedChan QuoteData -> [T.Text] -> Context -> T.Text -> IO QuoteSourceClientHandle
startQuoteSourceClient chan tickers ctx endpoint = do startQuoteSourceClient chan tickers ctx endpoint = do
compMv <- newEmptyMVar compMv <- newEmptyMVar
killMv <- newEmptyMVar killMv <- newEmptyMVar
@ -67,7 +72,9 @@ startQuoteSourceClient chan tickers ctx endpoint = do
prevHeartbeat <- readIORef lastHeartbeat prevHeartbeat <- readIORef lastHeartbeat
if headMay rawTick == Just "SYSTEM#HEARTBEAT" if headMay rawTick == Just "SYSTEM#HEARTBEAT"
then writeIORef lastHeartbeat now then writeIORef lastHeartbeat now
else writeList2Chan chan (deserializeTicks rawTick) else case deserializeBar rawTick of
Just (tf, bar) -> writeChan chan $ QDBar (tf, bar)
_ -> writeList2Chan chan (deserializeTicks rawTick)
debugM "QuoteSource.Client" "Heartbeat timeout") debugM "QuoteSource.Client" "Heartbeat timeout")
notTimeout ts = do notTimeout ts = do

65
src/ATrade/QuoteSource/Server.hs
Unescape View File

@ -5,36 +5,37 @@ module ATrade.QuoteSource.Server (
QuoteSourceServerData(..) QuoteSourceServerData(..)
) where ) where
import ATrade.Types import ATrade.Types
import Control.Concurrent.BoundedChan import Control.Concurrent hiding (readChan, writeChan)
import Control.Concurrent hiding (readChan, writeChan) import Control.Concurrent.BoundedChan
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import qualified Data.List as L import qualified Data.ByteString as B
import qualified Data.Text as T import qualified Data.ByteString.Char8 as B8
import qualified Data.Text.Encoding as E import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as B8 import Data.Foldable
import qualified Data.ByteString.Lazy as BL import qualified Data.List as L
import qualified Data.ByteString as B import Data.List.NonEmpty hiding (map)
import Data.List.NonEmpty hiding (map) import Data.Maybe
import Data.Maybe import qualified Data.Text as T
import System.Log.Logger import qualified Data.Text.Encoding as E
import System.ZMQ4 import Prelude hiding ((!!))
import System.ZMQ4.ZAP import System.Log.Logger
import Prelude hiding ((!!)) import System.ZMQ4
import System.ZMQ4.ZAP
import Safe
import Safe
data QuoteSourceServer = QuoteSourceServerState { data QuoteSourceServer = QuoteSourceServerState {
ctx :: Context, ctx :: Context,
outSocket :: Socket Pub, outSocket :: Socket Pub,
tickChannel :: BoundedChan QuoteSourceServerData, tickChannel :: BoundedChan QuoteSourceServerData,
completionMvar :: MVar (), completionMvar :: MVar (),
serverThreadId :: ThreadId, serverThreadId :: ThreadId,
heartbeatThreadId :: ThreadId heartbeatThreadId :: ThreadId
} }
data QuoteSourceServerData = QSSTick Tick | QSSHeartbeat | QSSKill data QuoteSourceServerData = QSSTick Tick | QSSBar (BarTimeframe, Bar) | QSSHeartbeat | QSSKill
deriving (Show, Eq) deriving (Show, Eq)
serverThread :: QuoteSourceServer -> IO () serverThread :: QuoteSourceServer -> IO ()
@ -50,12 +51,15 @@ serverThread state = do
qssdata' <- readChan $ tickChannel state qssdata' <- readChan $ tickChannel state
qssdata <- readChanN 15 $ tickChannel state qssdata <- readChanN 15 $ tickChannel state
let fulldata = qssdata' : qssdata let fulldata = qssdata' : qssdata
let tickGroups = L.groupBy (\x y -> security x == security y) $ mapMaybe onlyTick fulldata let (ticks, bars) = getTicksAndBars fulldata
let tickGroups = L.groupBy (\x y -> security x == security y) $ ticks
mapM_ (\ticks -> case headMay ticks of mapM_ (\ticks -> case headMay ticks of
Just h -> sendTicks (security h) ticks Just h -> sendTicks (security h) ticks
Nothing -> return()) tickGroups Nothing -> return()) tickGroups
mapM_ sendBar bars
when (QSSHeartbeat `elem` fulldata) $ send (outSocket state) [] $ B8.pack "SYSTEM#HEARTBEAT" when (QSSHeartbeat `elem` fulldata) $ send (outSocket state) [] $ B8.pack "SYSTEM#HEARTBEAT"
unless (QSSKill `elem` fulldata) serverThread' unless (QSSKill `elem` fulldata) serverThread'
@ -72,9 +76,14 @@ serverThread state = do
onlyTick t = case t of onlyTick t = case t of
QSSTick tick -> Just tick QSSTick tick -> Just tick
_ -> Nothing _ -> Nothing
getTicksAndBars = foldl' (\(tl, bl) qss -> case qss of
QSSTick t -> (t : tl, bl)
QSSBar b -> (tl, b : bl)
_ -> (tl, bl)) ([], [])
sendTicks secName ticklist = sendMulti (outSocket state) $ fromList . map BL.toStrict $ serializedTicks secName ticklist sendTicks secName ticklist = sendMulti (outSocket state) $ fromList . map BL.toStrict $ serializedTicks secName ticklist
sendBar (tf, bar) = sendMulti (outSocket state) $ fromList . map BL.toStrict $ serializeBar tf bar
serializedTicks secName ticklist = header : [body] serializedTicks secName ticklist = header : [body]
where where
header = BL.fromStrict . E.encodeUtf8 $ secName header = BL.fromStrict . E.encodeUtf8 $ secName

241
src/ATrade/Types.hs
Unescape View File

@ -1,10 +1,16 @@
{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
module ATrade.Types ( module ATrade.Types (
TickerId, TickerId,
Tick(..), Tick(..),
Bar(..), Bar(..),
serializeBar,
serializeBarBody,
deserializeBar,
BarTimeframe(..),
DataType(..), DataType(..),
serializeTick, serializeTick,
serializeTickBody, serializeTickBody,
@ -25,28 +31,28 @@ module ATrade.Types (
module ATrade.Price module ATrade.Price
) where ) where
import GHC.Generics import GHC.Generics
import ATrade.Price import ATrade.Price
import Control.Monad import Control.Monad
import Data.Aeson import Data.Aeson
import Data.Aeson.Types import Data.Aeson.Types
import Data.Binary.Builder import Data.Binary.Get
import Data.Binary.Get import Data.Binary.Put
import Data.ByteString.Lazy as B import Data.ByteString.Lazy as B
import Data.DateTime import Data.DateTime
import Data.Int import Data.Int
import Data.List as L import Data.List as L
import Data.Maybe import Data.Maybe
import Data.Ratio import Data.Ratio
import Data.Text as T import Data.Text as T
import Data.Text.Encoding as E import Data.Text.Encoding as E
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import Data.Word import Data.Word
import System.ZMQ4.ZAP import System.ZMQ4.ZAP
type TickerId = T.Text type TickerId = T.Text
@ -89,25 +95,36 @@ instance Enum DataType where
| otherwise = Unknown | otherwise = Unknown
data Tick = Tick { data Tick = Tick {
security :: !T.Text, security :: !T.Text,
datatype :: !DataType, datatype :: !DataType,
timestamp :: !UTCTime, timestamp :: !UTCTime,
value :: !Price, value :: !Price,
volume :: !Integer volume :: !Integer
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
putPrice :: Price -> Put
putPrice price = do
let (i, f) = decompose price
putWord64le $ fromInteger . toInteger $ i
putWord32le $ (* 1000) . fromInteger . toInteger $ f
parsePrice :: Get Price
parsePrice = do
intpart <- (fromIntegral <$> getWord64le) :: Get Int64
nanopart <- (fromIntegral <$> getWord32le) :: Get Int32
return $ compose (intpart, nanopart `div` 1000)
serializeTickHeader :: Tick -> ByteString serializeTickHeader :: Tick -> ByteString
serializeTickHeader tick = B.fromStrict . E.encodeUtf8 $ security tick serializeTickHeader tick = B.fromStrict . E.encodeUtf8 $ security tick
serializeTickBody :: Tick -> ByteString serializeTickBody :: Tick -> ByteString
serializeTickBody tick = toLazyByteString $ mconcat [ serializeTickBody tick = runPut $ do
putWord32le 1, putWord32le 1
putWord64le $ fromIntegral . toSeconds' . timestamp $ tick, putWord64le $ fromIntegral . toSeconds' . timestamp $ tick
putWord32le $ fromIntegral . fracSeconds . timestamp $ tick, putWord32le $ fromIntegral . fracSeconds . timestamp $ tick
putWord32le $ fromIntegral . fromEnum . datatype $ tick, putWord32le $ fromIntegral . fromEnum . datatype $ tick
putWord64le $ fromInteger . toInteger . fst . decompose . value $ tick, putPrice $ value tick
putWord32le $ (* 1000) . fromInteger . toInteger . snd . decompose . value $ tick, putWord32le $ fromIntegral $ volume tick
putWord32le $ fromIntegral $ volume tick ]
where where
fractionalPart :: (RealFrac a) => a -> a fractionalPart :: (RealFrac a) => a -> a
fractionalPart x = x - fromIntegral (truncate x) fractionalPart x = x - fromIntegral (truncate x)
@ -125,17 +142,16 @@ parseTick = do
tsec <- getWord64le tsec <- getWord64le
tusec <- getWord32le tusec <- getWord32le
dt <- toEnum . fromEnum <$> getWord32le dt <- toEnum . fromEnum <$> getWord32le
intpart <- (fromIntegral <$> getWord64le) :: Get Int64 price <- parsePrice
nanopart <- (fromIntegral <$> getWord32le) :: Get Int32
volume <- fromIntegral <$> (fromIntegral <$> getWord32le :: Get Int32) volume <- fromIntegral <$> (fromIntegral <$> getWord32le :: Get Int32)
return Tick { security = "", return Tick { security = "",
datatype = dt, datatype = dt,
timestamp = makeTimestamp tsec tusec, timestamp = makeTimestamp tsec tusec,
value = compose (intpart, nanopart `div` 1000), value = price,
volume = volume } volume = volume }
where
makeTimestamp :: Word64 -> Word32 -> UTCTime makeTimestamp :: Word64 -> Word32 -> UTCTime
makeTimestamp sec usec = addUTCTime (fromRational $ toInteger usec % 1000000) (fromSeconds . toInteger $ sec) makeTimestamp sec usec = addUTCTime (fromRational $ toInteger usec % 1000000) (fromSeconds . toInteger $ sec)
deserializeTick :: [ByteString] -> Maybe Tick deserializeTick :: [ByteString] -> Maybe Tick
deserializeTick (header:rawData:_) = case runGetOrFail parseTick rawData of deserializeTick (header:rawData:_) = case runGetOrFail parseTick rawData of
@ -146,23 +162,84 @@ deserializeTick _ = Nothing
deserializeTickBody :: ByteString -> (ByteString, Maybe Tick) deserializeTickBody :: ByteString -> (ByteString, Maybe Tick)
deserializeTickBody bs = case runGetOrFail parseTick bs of deserializeTickBody bs = case runGetOrFail parseTick bs of
Left (rest, _, _) -> (rest, Nothing) Left (rest, _, _) -> (rest, Nothing)
Right (rest, _, tick) -> (rest, Just tick) Right (rest, _, tick) -> (rest, Just tick)
data Bar = Bar { data Bar = Bar {
barSecurity :: !TickerId, barSecurity :: !TickerId,
barTimestamp :: !UTCTime, barTimestamp :: !UTCTime,
barOpen :: !Price, barOpen :: !Price,
barHigh :: !Price, barHigh :: !Price,
barLow :: !Price, barLow :: !Price,
barClose :: !Price, barClose :: !Price,
barVolume :: !Integer barVolume :: !Integer
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
-- | Stores timeframe in seconds
newtype BarTimeframe = BarTimeframe { unBarTimeframe :: Int }
deriving (Show, Eq)
serializeBar :: BarTimeframe -> Bar -> [ByteString]
serializeBar tf bar = serializeBarHeader tf bar : [serializeBarBody tf bar]
-- | Encodes bar header as tickerid:timeframe_seconds;
-- Why ';' at the end? To support correct 0mq subscriptions. When we subscribe to topic,
-- we actually subscribe by all topics which has requested subscription as a prefix.
serializeBarHeader :: BarTimeframe -> Bar -> ByteString
serializeBarHeader tf bar =
B.fromStrict . E.encodeUtf8 $ (barSecurity bar) `T.append` encodeTimeframe tf
where
encodeTimeframe tf = mconcat [ ":", (T.pack . show $ unBarTimeframe tf), ";" ]
serializeBarBody :: BarTimeframe -> Bar -> ByteString
serializeBarBody tf bar = runPut $ do
putWord32le 2
putWord32le $ fromIntegral $ unBarTimeframe tf
putWord64le $ fromIntegral . toSeconds' . barTimestamp $ bar
putWord32le $ fromIntegral . fracSeconds . barTimestamp $ bar
putPrice $ barOpen bar
putPrice $ barHigh bar
putPrice $ barLow bar
putPrice $ barClose bar
putWord32le $ fromIntegral $ barVolume bar
where
fractionalPart :: (RealFrac a) => a -> a
fractionalPart x = x - fromIntegral (truncate x)
toSeconds' = floor . utcTimeToPOSIXSeconds
fracSeconds t = (truncate $ (* 1000000000000) $ utcTimeToPOSIXSeconds t) `mod` 1000000000000 `div` 1000000
parseBar :: Get (BarTimeframe, Bar)
parseBar = do
packetType <- fromEnum <$> getWord32le
when (packetType /= 2) $ fail "Expected packettype == 2"
tf <- fromIntegral <$> getWord32le
tsec <- getWord64le
tusec <- getWord32le
open_ <- parsePrice
high_ <- parsePrice
low_ <- parsePrice
close_ <- parsePrice
volume_ <- fromIntegral <$> getWord32le
return (BarTimeframe tf, Bar { barSecurity = "",
barTimestamp = makeTimestamp tsec tusec,
barOpen = open_,
barHigh = high_,
barLow = low_,
barClose = close_,
barVolume = volume_ })
deserializeBar :: [ByteString] -> Maybe (BarTimeframe, Bar)
deserializeBar (header:rawData:_) = case runGetOrFail parseBar rawData of
Left (_, _, _) -> Nothing
Right (_, _, (tf, bar)) -> Just $ (tf, bar { barSecurity = T.takeWhile (/= ':') . E.decodeUtf8 . B.toStrict $ header })
deserializeBar _ = Nothing
data SignalId = SignalId { data SignalId = SignalId {
strategyId :: T.Text, strategyId :: T.Text,
signalName :: T.Text, signalName :: T.Text,
comment :: T.Text } comment :: T.Text }
deriving (Show, Eq) deriving (Show, Eq)
instance FromJSON SignalId where instance FromJSON SignalId where
@ -223,7 +300,7 @@ instance FromJSON Operation where
parseJSON _ = fail "Should be string" parseJSON _ = fail "Should be string"
instance ToJSON Operation where instance ToJSON Operation where
toJSON Buy = String "buy" toJSON Buy = String "buy"
toJSON Sell = String "sell" toJSON Sell = String "sell"
data OrderState = Unsubmitted data OrderState = Unsubmitted
@ -250,26 +327,26 @@ instance FromJSON OrderState where
instance ToJSON OrderState where instance ToJSON OrderState where
toJSON os = case os of toJSON os = case os of
Unsubmitted -> String "unsubmitted" Unsubmitted -> String "unsubmitted"
Submitted -> String "submitted" Submitted -> String "submitted"
PartiallyExecuted -> String "partially-executed" PartiallyExecuted -> String "partially-executed"
Executed -> String "executed" Executed -> String "executed"
Cancelled -> String "cancelled" Cancelled -> String "cancelled"
Rejected -> String "rejected" Rejected -> String "rejected"
OrderError -> String "error" OrderError -> String "error"
type OrderId = Integer type OrderId = Integer
data Order = Order { data Order = Order {
orderId :: OrderId, orderId :: OrderId,
orderAccountId :: T.Text, orderAccountId :: T.Text,
orderSecurity :: T.Text, orderSecurity :: T.Text,
orderPrice :: OrderPrice, orderPrice :: OrderPrice,
orderQuantity :: Integer, orderQuantity :: Integer,
orderExecutedQuantity :: Integer, orderExecutedQuantity :: Integer,
orderOperation :: Operation, orderOperation :: Operation,
orderState :: OrderState, orderState :: OrderState,
orderSignalId :: SignalId } orderSignalId :: SignalId }
deriving (Show, Eq) deriving (Show, Eq)
mkOrder = Order { orderId = 0, mkOrder = Order { orderId = 0,
@ -310,17 +387,17 @@ instance ToJSON Order where
ifMaybe name pred val = if pred val then Just (name .= val) else Nothing ifMaybe name pred val = if pred val then Just (name .= val) else Nothing
data Trade = Trade { data Trade = Trade {
tradeOrderId :: OrderId, tradeOrderId :: OrderId,
tradePrice :: Price, tradePrice :: Price,
tradeQuantity :: Integer, tradeQuantity :: Integer,
tradeVolume :: Price, tradeVolume :: Price,
tradeVolumeCurrency :: T.Text, tradeVolumeCurrency :: T.Text,
tradeOperation :: Operation, tradeOperation :: Operation,
tradeAccount :: T.Text, tradeAccount :: T.Text,
tradeSecurity :: T.Text, tradeSecurity :: T.Text,
tradeTimestamp :: UTCTime, tradeTimestamp :: UTCTime,
tradeCommission :: Price, tradeCommission :: Price,
tradeSignalId :: SignalId } tradeSignalId :: SignalId }
deriving (Show, Eq) deriving (Show, Eq)
instance FromJSON Trade where instance FromJSON Trade where
@ -352,7 +429,7 @@ instance ToJSON Trade where
"signal-id" .= tradeSignalId trade] "signal-id" .= tradeSignalId trade]
data ServerSecurityParams = ServerSecurityParams { data ServerSecurityParams = ServerSecurityParams {
sspDomain :: Maybe T.Text, sspDomain :: Maybe T.Text,
sspCertificate :: Maybe CurveCertificate sspCertificate :: Maybe CurveCertificate
} deriving (Show, Eq) } deriving (Show, Eq)
@ -362,8 +439,8 @@ defaultServerSecurityParams = ServerSecurityParams {
} }
data ClientSecurityParams = ClientSecurityParams { data ClientSecurityParams = ClientSecurityParams {
cspDomain :: Maybe T.Text, cspDomain :: Maybe T.Text,
cspCertificate :: Maybe CurveCertificate, cspCertificate :: Maybe CurveCertificate,
cspServerCertificate :: Maybe CurveCertificate cspServerCertificate :: Maybe CurveCertificate
} deriving (Show, Eq) } deriving (Show, Eq)
@ -373,10 +450,10 @@ defaultClientSecurityParams = ClientSecurityParams {
} }
data TickerInfo = TickerInfo { data TickerInfo = TickerInfo {
tiTicker :: TickerId, tiTicker :: TickerId,
tiClass :: T.Text, tiClass :: T.Text,
tiBase :: Maybe TickerId, tiBase :: Maybe TickerId,
tiLotSize :: Integer, tiLotSize :: Integer,
tiTickSize :: Price tiTickSize :: Price
} deriving (Show, Eq) } deriving (Show, Eq)

2
stack.yaml
Unescape View File

@ -40,7 +40,7 @@ packages:
- '../zeromq4-haskell-zap' - '../zeromq4-haskell-zap'
# Dependency packages to be pulled from upstream that are not in the resolver # Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3) # (e.g., acme-missiles-0.3)
extra-deps: [ "datetime-0.3.1", "hexdump-0.1"] extra-deps: [ "datetime-0.3.1", "hexdump-0.1", "text-format-0.3.2"]
# Override default flag values for local packages and extra-deps # Override default flag values for local packages and extra-deps
flags: {} flags: {}

33
test/ArbitraryInstances.hs
Unescape View File

@ -10,6 +10,7 @@ import Test.QuickCheck.Instances ()
import ATrade.Types import ATrade.Types
import ATrade.Price as P import ATrade.Price as P
import qualified Data.Text as T
import ATrade.Broker.Protocol import ATrade.Broker.Protocol
import Data.Time.Clock import Data.Time.Clock
@ -18,22 +19,24 @@ import Data.Time.Calendar
notTooBig :: (Num a, Ord a) => a -> Bool notTooBig :: (Num a, Ord a) => a -> Bool
notTooBig x = abs x < 100000000 notTooBig x = abs x < 100000000
arbitraryTickerId = arbitrary `suchThat` (T.all (/= ':'))
instance Arbitrary Tick where instance Arbitrary Tick where
arbitrary = Tick <$> arbitrary = Tick <$>
arbitrary <*> arbitraryTickerId <*>
arbitrary <*> arbitrary <*>
arbitraryTimestamp <*> arbitraryTimestamp <*>
arbitrary <*> arbitrary <*>
arbitrary arbitrary
where
arbitraryTimestamp = do
y <- choose (1970, 2050)
m <- choose (1, 12)
d <- choose (1, 31)
sec <- secondsToDiffTime <$> choose (0, 86399) arbitraryTimestamp = do
y <- choose (1970, 2050)
m <- choose (1, 12)
d <- choose (1, 31)
sec <- secondsToDiffTime <$> choose (0, 86399)
return $ UTCTime (fromGregorian y m d) sec return $ UTCTime (fromGregorian y m d) sec
instance Arbitrary DataType where instance Arbitrary DataType where
arbitrary = toEnum <$> choose (1, 10) arbitrary = toEnum <$> choose (1, 10)
@ -116,3 +119,17 @@ instance Arbitrary BrokerServerResponse where
instance Arbitrary P.Price where instance Arbitrary P.Price where
arbitrary = P.Price <$> (arbitrary `suchThat` (\p -> abs p < 1000000000 * 10000000)) arbitrary = P.Price <$> (arbitrary `suchThat` (\p -> abs p < 1000000000 * 10000000))
instance Arbitrary Bar where
arbitrary = Bar <$>
arbitraryTickerId <*>
arbitraryTimestamp <*>
arbitrary <*>
arbitrary <*>
arbitrary <*>
arbitrary <*>
arbitrary `suchThat` (> 0)
instance Arbitrary BarTimeframe where
arbitrary = BarTimeframe <$> (arbitrary `suchThat` (\p -> p > 0 && p < 86400 * 365))

59
test/TestQuoteSourceClient.hs
Unescape View File

@ -4,22 +4,22 @@ module TestQuoteSourceClient (
unitTests unitTests
) where ) where
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import ATrade.Types import ATrade.QuoteSource.Client
import ATrade.QuoteSource.Server import ATrade.QuoteSource.Server
import ATrade.QuoteSource.Client import ATrade.Types
import Control.Monad import Control.Concurrent hiding (readChan, writeChan)
import Control.Concurrent.BoundedChan import Control.Concurrent.BoundedChan
import Control.Concurrent hiding (writeChan, readChan) import Control.Exception
import Control.Exception import Control.Monad
import System.ZMQ4 import qualified Data.Text as T
import Data.Time.Clock import Data.Time.Calendar
import Data.Time.Calendar import Data.Time.Clock
import qualified Data.Text as T import Data.UUID as U
import Data.UUID as U import Data.UUID.V4 as UV4
import Data.UUID.V4 as UV4 import System.ZMQ4
makeEndpoint :: IO T.Text makeEndpoint :: IO T.Text
makeEndpoint = do makeEndpoint = do
@ -27,7 +27,10 @@ makeEndpoint = do
return $ "inproc://server" `T.append` uid return $ "inproc://server" `T.append` uid
unitTests :: TestTree unitTests :: TestTree
unitTests = testGroup "QuoteSource.Client" [testStartStop, testTickStream] unitTests = testGroup "QuoteSource.Client" [
testStartStop
, testTickStream
, testBarStream ]
testStartStop :: TestTree testStartStop :: TestTree
testStartStop = testCase "QuoteSource client connects and disconnects" $ withContext (\ctx -> do testStartStop = testCase "QuoteSource client connects and disconnects" $ withContext (\ctx -> do
@ -51,6 +54,24 @@ testTickStream = testCase "QuoteSource clients receives ticks" $ withContext (\c
value = 1000, value = 1000,
volume = 1} volume = 1}
forkIO $ forever $ writeChan chan (QSSTick tick) forkIO $ forever $ writeChan chan (QSSTick tick)
recvdTick <- readChan clientChan recvdData <- readChan clientChan
tick @=? recvdTick))) QDTick tick @=? recvdData)))
testBarStream :: TestTree
testBarStream = testCase "QuoteSource clients receives bars" $ 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
let bar = Bar {
barSecurity = "FOOBAR",
barTimestamp = UTCTime (fromGregorian 2016 9 27) 16000,
barOpen = fromDouble 10.0,
barHigh = fromDouble 15.0,
barLow = fromDouble 8.0,
barClose = fromDouble 11.0,
barVolume = 42 }
forkIO $ forever $ writeChan chan $ QSSBar (BarTimeframe 60, bar)
recvdData <- readChan clientChan
QDBar (BarTimeframe 60, bar) @=? recvdData)))

50
test/TestQuoteSourceServer.hs
Unescape View File

@ -4,20 +4,23 @@ module TestQuoteSourceServer (
unitTests unitTests
) where ) where
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import ATrade.Types import ATrade.QuoteSource.Server
import qualified Data.ByteString.Lazy as BL import ATrade.Types
import ATrade.QuoteSource.Server import Control.Concurrent.BoundedChan
import Control.Concurrent.BoundedChan import Control.Exception
import Control.Exception import qualified Data.ByteString.Lazy as BL
import System.ZMQ4 import Data.Time.Calendar
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Calendar import System.ZMQ4
unitTests :: TestTree unitTests :: TestTree
unitTests = testGroup "QuoteSource.Server" [testStartStop, testTickStream] unitTests = testGroup "QuoteSource.Server" [
testStartStop
, testTickStream
, testBarStream ]
testStartStop :: TestTree testStartStop :: TestTree
testStartStop = testCase "QuoteSource Server starts and stops" $ withContext (\ctx -> do testStartStop = testCase "QuoteSource Server starts and stops" $ withContext (\ctx -> do
@ -42,5 +45,26 @@ testTickStream = testCase "QuoteSource Server sends ticks" $ withContext (\ctx -
packet <- fmap BL.fromStrict <$> receiveMulti s packet <- fmap BL.fromStrict <$> receiveMulti s
case deserializeTick packet of case deserializeTick packet of
Just recvdTick -> tick @=? recvdTick Just recvdTick -> tick @=? recvdTick
Nothing -> assertFailure "Unable to deserialize tick"))) Nothing -> assertFailure "Unable to deserialize tick")))
testBarStream :: TestTree
testBarStream = testCase "QuoteSource Server sends bars" $ withContext (\ctx -> do
chan <- newBoundedChan 1000
bracket (startQuoteSourceServer chan ctx "inproc://quotesource-server" Nothing) stopQuoteSourceServer (\_ ->
withSocket ctx Sub (\s -> do
connect s "inproc://quotesource-server"
subscribe s "FOOBAR"
let bar = Bar {
barSecurity = "FOOBAR",
barTimestamp = UTCTime (fromGregorian 2016 9 27) 16000,
barOpen = fromDouble 10.0,
barHigh = fromDouble 15.0,
barLow = fromDouble 8.0,
barClose = fromDouble 11.0,
barVolume = 1 }
writeChan chan (QSSBar (BarTimeframe 60, bar))
packet <- fmap BL.fromStrict <$> receiveMulti s
case deserializeBar packet of
Just (barTf, recvdBar) -> (bar @=? recvdBar) >> (barTf @=? (BarTimeframe 60))
Nothing -> assertFailure "Unable to deserialize bar")))

8
test/TestTypes.hs
Unescape View File

@ -15,6 +15,8 @@ import ArbitraryInstances ()
import Data.Aeson import Data.Aeson
import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy as B
import Debug.Trace
properties :: TestTree properties :: TestTree
properties = testGroup "Types" [ properties = testGroup "Types" [
testTickSerialization testTickSerialization
@ -31,6 +33,7 @@ properties = testGroup "Types" [
, testPriceAddition , testPriceAddition
, testPriceMultiplication , testPriceMultiplication
, testPriceSubtraction , testPriceSubtraction
, testBarSerialization
] ]
testTickSerialization :: TestTree testTickSerialization :: TestTree
@ -116,3 +119,8 @@ 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)
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)

Write Preview
Loading…
Cancel
Save