asakul
/
quik-connector
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Update pipe reader

master
Denis Tereshkin 7 years ago
parent
e2608a0bec
commit
1545c28943
5 changed files with 54 additions and 149 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. 14
      app/Main.hs
  2. 2
      app/Version.hs
  3. 4
      quik-connector.cabal
  4. 22
      src/QuoteSource/DataImport.hs
  5. 161
      src/QuoteSource/PipeReader.hs

14
app/Main.hs
Unescape View File

@ -109,7 +109,7 @@ main = do
let serverParams = defaultServerSecurityParams { sspDomain = Just "global", let serverParams = defaultServerSecurityParams { sspDomain = Just "global",
sspCertificate = serverCert } sspCertificate = serverCert }
bracket (forkIO $ pipeReaderThread ctx config) killThread (\_ -> do bracket (forkIO $ pipeReaderThread ctx config c2) killThread (\_ -> do
withZMQTradeSink ctx (tradeSink config) (\zmqTradeSink -> do withZMQTradeSink ctx (tradeSink config) (\zmqTradeSink -> do
withZMQTradeSink ctx (tradeSink2 config) (\zmqTradeSink2 -> do withZMQTradeSink ctx (tradeSink2 config) (\zmqTradeSink2 -> do
bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config) (Just "global")) stopQuoteSourceServer (\_ -> do bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config) (Just "global")) stopQuoteSourceServer (\_ -> do
@ -127,13 +127,11 @@ main = do
void $ timeout 1000000 $ killThread forkId void $ timeout 1000000 $ killThread forkId
infoM "main" "Main thread done" infoM "main" "Main thread done"
where where
pipeReaderThread ctx config = pipeReaderThread ctx config qsdataChan =
case (tickPipePath config, pipeReaderQsEndpoint config) of case pipeReaderQsEndpoint config of
(Just pipe, Just qsep) -> do Just qsep -> do
infoM "main" $ "Pipe/QS: " ++ pipe ++ "/" ++ qsep infoM "main" $ "QS: " ++ qsep
tickChan <- newBoundedChan 10000 bracket (startPipeReader ctx (T.pack qsep) qsdataChan) stopPipeReader (\_ -> forever $ threadDelay 1000000)
bracket (startPipeReader ctx (T.pack pipe) tickChan) stopPipeReader (\_ -> do
bracket (startQuoteSourceServer tickChan ctx (T.pack qsep) (Just "global")) stopQuoteSourceServer (\_ -> forever $ threadDelay 1000000))
_ -> return () _ -> return ()

2
app/Version.hs
Unescape View File

@ -10,7 +10,7 @@ import qualified Data.Text as T
import Text.Printf.TH import Text.Printf.TH
quikConnectorVersion :: (Int, Int, Int, Int) quikConnectorVersion :: (Int, Int, Int, Int)
quikConnectorVersion = (0, 3, 0, 0) quikConnectorVersion = (0, 4, 0, 0)
quikConnectorVersionText :: T.Text quikConnectorVersionText :: T.Text
quikConnectorVersionText = quikConnectorVersionText =

4
quik-connector.cabal
Unescape View File

@ -1,5 +1,5 @@
name: quik-connector name: quik-connector
version: 0.3.0.0 version: 0.4.0.0
synopsis: Atrade-Quik Connector application synopsis: Atrade-Quik Connector application
description: Please see README.md description: Please see README.md
homepage: https://github.com/asakul/quik-connector homepage: https://github.com/asakul/quik-connector
@ -49,7 +49,7 @@ library
, aeson , aeson
, cond , cond
, scientific , scientific
, libatrade == 0.7.0.0 , libatrade == 0.8.0.0
, deepseq , deepseq
, errors , errors
, split , split

22
src/QuoteSource/DataImport.hs
Unescape View File

@ -6,20 +6,20 @@ module QuoteSource.DataImport
shutdownDataImportServer shutdownDataImportServer
) where ) where
import Control.Concurrent.BoundedChan import ATrade.Types
import Control.Monad.State.Strict import Control.Concurrent.BoundedChan
import ATrade.Types import Control.Monad.State.Strict
import Data.IORef import Data.IORef
import Data.Time.Clock import Data.Time.Clock
import QuoteSource.TableParser import QuoteSource.TableParser
import System.Win32.DDE import System.Win32.DDE
import System.Win32.XlParser import System.Win32.XlParser
import qualified Data.Map as M import qualified Data.Map as M
data ServerState = ServerState { data ServerState = ServerState {
appName :: String, appName :: String,
parsers :: IORef (M.Map String TableParserInstance), parsers :: IORef (M.Map String TableParserInstance),
tickChannel :: BoundedChan Tick tickChannel :: BoundedChan Tick
} }

161
src/QuoteSource/PipeReader.hs
Unescape View File

@ -17,11 +17,12 @@ import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.Extra import Control.Monad.Extra
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Loops import Control.Monad.Loops (whileM_)
import Data.Attoparsec.Text import Data.Binary
import Data.Binary.Get
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Conduit hiding (connect) import Data.Conduit hiding (connect)
import Data.Conduit.Attoparsec
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import qualified Data.HashSet as HS import qualified Data.HashSet as HS
import Data.IORef import Data.IORef
@ -29,7 +30,6 @@ import qualified Data.Map.Strict as M
import Data.Maybe import Data.Maybe
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding import Data.Text.Encoding
import qualified Data.Text.Foreign as FT
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.Clock import Data.Time.Clock
import Foreign.Marshal.Alloc import Foreign.Marshal.Alloc
@ -45,144 +45,51 @@ data PipeReaderHandle =
running :: IORef Bool running :: IORef Bool
} deriving (Eq) } deriving (Eq)
data DataLine = CurrentParamLine T.Text Double Integer Double Integer Integer Double Integer Integer
| AllTradeLine T.Text Integer Double Integer UTCTime
deriving (Show, Eq)
yieldJust :: Maybe a -> Source IO a zmqSocketConduit :: (Subscriber a, Receiver a) => T.Text -> Socket a -> IORef Bool -> Source IO [B.ByteString]
yieldJust maybeV = do -- Probably already present in some library zmqSocketConduit ep sock running' = do
case maybeV of liftIO $ do
Just v -> yield v debugM "PipeReader" $ "Connecting to: " ++ T.unpack ep
Nothing -> return () connect sock (T.unpack ep)
subscribe sock B.empty
zmqSocketConduit :: (Receiver a) => Socket a -> Source IO T.Text lastHeartbeat <- liftIO $ getCurrentTime >>= newIORef
zmqSocketConduit sock = do whileM_ (andM [notTimeout lastHeartbeat, liftIO (readIORef running')]) $ do
maybeStr <- liftIO $ do evs <- liftIO $ poll 200 [Sock sock [In] Nothing]
bs <- receive sock unless (null (head evs)) $ do
case decodeUtf8' bs of bs <- liftIO $ receiveMulti sock
Left _ -> return Nothing when ((not . null $ bs) && (head bs == "SYSTEM#HEARTBEAT")) $ liftIO $ getCurrentTime >>= writeIORef lastHeartbeat
Right v -> return (Just v) yield bs
yieldJust maybeStr zmqSocketConduit ep sock running'
zmqSocketConduit sock where
notTimeout hb = do
line2TickConduit :: Conduit DataLine IO Tick now <- liftIO $ getCurrentTime
line2TickConduit = do last <- liftIO $ readIORef hb
volumeMap <- liftIO $ newIORef M.empty return $ now `diffUTCTime` last < 10
ignoreCPSet <- liftIO $ newIORef HS.empty
lastTimestamp <- liftIO $ newIORef $ UTCTime (fromGregorian 1970 1 1) 0
awaitForever $ \line ->
case line of
CurrentParamLine tickerId last voltoday bid biddepth biddeptht offer offerdepth offerdeptht -> do
ts <- liftIO $ readIORef lastTimestamp
yieldTick tickerId BestBid ts (fromDouble bid) biddepth
yieldTick tickerId BestOffer ts (fromDouble offer) offerdepth
yieldTick tickerId TotalSupply ts (fromInteger offerdeptht) 0
yieldTick tickerId TotalDemand ts (fromInteger biddeptht) 0
shouldParsePrice <- liftIO $ HS.member tickerId <$> readIORef ignoreCPSet
when shouldParsePrice $ do
m <- liftIO $ readIORef volumeMap
case M.lookup tickerId m of
Just vol ->
if | vol < voltoday -> yieldTick tickerId LastTradePrice ts (fromDouble last) (voltoday - vol)
| vol > voltoday -> yieldTick tickerId LastTradePrice ts (fromDouble last) vol
| otherwise -> return ()
Nothing -> yieldTick tickerId LastTradePrice ts (fromDouble last) 1
liftIO $ atomicModifyIORef' volumeMap (\m -> (M.insert tickerId voltoday m, ()))
AllTradeLine tickerId flags price volume ts -> do parseBarConduit :: Conduit [B.ByteString] IO (TickerId, BarTimeframe, Bar)
liftIO $ writeIORef lastTimestamp ts parseBarConduit = awaitForever $ \bs ->
if case deserializeBar (BL.fromStrict <$> bs) of
| flags == 1 -> yieldTick tickerId LastTradePrice ts (fromDouble price) volume Just (tf, bar) -> yield (barSecurity bar, tf, bar)
| flags == 2 -> yieldTick tickerId LastTradePrice ts (fromDouble price) volume _ -> return ()
| otherwise -> return ()
liftIO $ atomicModifyIORef' ignoreCPSet (\s -> (HS.insert tickerId s, ()))
where qssdataConduit :: Conduit (TickerId, BarTimeframe, Bar) IO QuoteSourceServerData
yieldTick tickerId dtype ts val vol = qssdataConduit = awaitForever $ \(tid, tf, bar) -> yield $ QSSBar (tf, bar)
yield $ Tick { security = tickerId,
datatype = dtype,
timestamp = ts,
value = val,
volume = vol }
chanSink :: BoundedChan QuoteSourceServerData -> Sink Tick IO () chanSink :: (Show a) => BoundedChan a -> Sink a IO ()
chanSink chan = awaitForever chanSink chan = awaitForever
(\t -> liftIO $ do (\t -> do
writeChan chan (QSSTick t)) liftIO $ writeChan chan t)
startPipeReader :: Context -> T.Text -> BoundedChan QuoteSourceServerData -> IO PipeReaderHandle startPipeReader :: Context -> T.Text -> BoundedChan QuoteSourceServerData -> IO PipeReaderHandle
startPipeReader ctx pipeEndpoint tickChan = do startPipeReader ctx pipeEndpoint tickChan = do
debugM "PipeReader" $ "Trying to open pipe: " ++ T.unpack pipeEndpoint debugM "PipeReader" $ "Trying to open pipe: " ++ T.unpack pipeEndpoint
s <- socket ctx Sub s <- socket ctx Sub
connect s (T.unpack pipeEndpoint)
subscribe s B.empty
debugM "PipeReader" "Pipe opened" debugM "PipeReader" "Pipe opened"
running' <- newIORef True running' <- newIORef True
tid <- forkIO $ readerThread s running' tid <- forkIO $ readerThread s running'
return PipeReaderHandle { prThreadId = tid, running = running' } return PipeReaderHandle { prThreadId = tid, running = running' }
where where
readerThread s running' = runConduit $ (zmqSocketConduit s) =$= conduitParserEither parseTrade =$= handleParseResult =$= line2TickConduit =$= chanSink tickChan readerThread s running' = runConduit $ (zmqSocketConduit pipeEndpoint s running') =$= parseBarConduit =$= qssdataConduit =$= chanSink tickChan
parseTrade = parseCurrentParam <|> parseAllTrade
parseCurrentParam = do
string "CT:"
secName <- takeTill (== ':')
string ":"
last <- double
string ";"
voltoday <- decimal
string ";"
bid <- double
string ";"
biddepth <- decimal
string ";"
biddeptht <- decimal
string ";"
offer <- double
string ";"
offerdepth <- decimal
string ";"
offerdeptht <- decimal
string ";"
return $ CurrentParamLine secName last voltoday bid biddepth biddeptht offer offerdepth offerdeptht
parseAllTrade = do
string "AT:"
secName <- takeTill (== ':')
string ":"
flags <- decimal
string ";"
price <- double
string ";"
qty <- decimal
string ";"
dt <- parseDateTime
string ";"
return $ AllTradeLine secName flags price qty dt
parseDateTime = do
y <- decimal
string "."
mon <- decimal
string "."
day <- decimal
string " "
h <- fromInteger <$> decimal
string ":"
m <- fromInteger <$> decimal
string ":"
s <- fromInteger <$> decimal
string "."
ms <- fromInteger <$> decimal
return $ UTCTime (fromGregorian y mon day) $ h * 3600 + m * 60 + s + ms / 1000
handleParseResult = do
awaitForever $ \res ->
case res of
Left err -> liftIO $ warningM "PipeReader" $ "Can't parse: " ++ show err
Right (_, r) -> yield r
stopPipeReader :: PipeReaderHandle -> IO () stopPipeReader :: PipeReaderHandle -> IO ()
stopPipeReader h = killThread (prThreadId h) >> writeIORef (running h) False stopPipeReader h = killThread (prThreadId h) >> writeIORef (running h) False

Write Preview
Loading…
Cancel
Save