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

Logging: use co-log && logging facilities from libatrade-0.11

junction
Denis Tereshkin 4 years ago
parent
bf7df5e98c
commit
632ca49d15
8 changed files with 94 additions and 41 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. 5
      robocom-zero.cabal
  2. 45
      src/ATrade/Driver/Junction.hs
  3. 22
      src/ATrade/Driver/Junction/QuoteThread.hs
  4. 15
      src/ATrade/Driver/Junction/RobotDriverThread.hs
  5. 5
      src/ATrade/Quotes/Finam.hs
  6. 18
      src/ATrade/Quotes/QHP.hs
  7. 15
      src/ATrade/Quotes/QTIS.hs
  8. 2
      stack.yaml

5
robocom-zero.cabal
Unescape View File

@ -24,7 +24,6 @@ library
, ATrade.RoboCom.Types , ATrade.RoboCom.Types
, ATrade.RoboCom.Utils , ATrade.RoboCom.Utils
, ATrade.Quotes , ATrade.Quotes
, ATrade.Quotes.Finam
, ATrade.Quotes.QHP , ATrade.Quotes.QHP
, ATrade.Quotes.QTIS , ATrade.Quotes.QTIS
-- , ATrade.Driver.Real -- , ATrade.Driver.Real
@ -41,7 +40,7 @@ library
, ATrade.Quotes.TickerInfoProvider , ATrade.Quotes.TickerInfoProvider
other-modules: Paths_robocom_zero other-modules: Paths_robocom_zero
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
, libatrade >= 0.10.0.0 && < 0.11.0.0 , libatrade >= 0.11.0.0 && < 0.12.0.0
, text , text
, text-icu , text-icu
, errors , errors
@ -53,7 +52,6 @@ library
, vector , vector
, wreq , wreq
, safe , safe
, hslogger
, parsec , parsec
, parsec-numbers , parsec-numbers
, aeson , aeson
@ -86,6 +84,7 @@ library
, async , async
, dhall , dhall
, extra , extra
, co-log
default-language: Haskell2010 default-language: Haskell2010
other-modules: ATrade.Exceptions other-modules: ATrade.Exceptions

45
src/ATrade/Driver/Junction.hs
Unescape View File

@ -38,12 +38,21 @@ import ATrade.Driver.Junction.Types (StrategyDescriptor
confStrategy, confStrategy,
strategyState, strategyState,
strategyTimers) strategyTimers)
import ATrade.Logging (Message,
Severity (Info),
fmtMessage,
logWarning,
logWith)
import ATrade.Quotes.QHP (mkQHPHandle) import ATrade.Quotes.QHP (mkQHPHandle)
import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig)) import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig))
import ATrade.RoboCom.Persistence (MonadPersistence (loadState, saveState)) import ATrade.RoboCom.Persistence (MonadPersistence (loadState, saveState))
import ATrade.Types (ClientSecurityParams (ClientSecurityParams), import ATrade.Types (ClientSecurityParams (ClientSecurityParams),
OrderId, OrderId,
Trade (tradeOrderId)) Trade (tradeOrderId))
import Colog (HasLog (getLogAction, setLogAction),
LogAction,
logTextStdout,
(>$<))
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Exception.Safe (MonadThrow, import Control.Exception.Safe (MonadThrow,
bracket) bracket)
@ -84,8 +93,8 @@ import Options.Applicative (Parser,
metavar, progDesc, metavar, progDesc,
short, strOption, short, strOption,
(<**>)) (<**>))
import Prelude hiding (readFile) import Prelude hiding (log,
import System.Log.Logger (warningM) readFile)
import System.ZMQ4 (withContext) import System.ZMQ4 (withContext)
import System.ZMQ4.ZAP (loadCertificateFromFile) import System.ZMQ4.ZAP (loadCertificateFromFile)
@ -96,12 +105,17 @@ data JunctionEnv =
peConfigPath :: FilePath, peConfigPath :: FilePath,
peQuoteThread :: QuoteThreadHandle, peQuoteThread :: QuoteThreadHandle,
peBroker :: BrokerClientHandle, peBroker :: BrokerClientHandle,
peRobots :: IORef (M.Map T.Text RobotDriverHandle) peRobots :: IORef (M.Map T.Text RobotDriverHandle),
peLogAction :: LogAction JunctionM Message
} }
newtype JunctionM a = JunctionM { unJunctionM :: ReaderT JunctionEnv IO a } newtype JunctionM a = JunctionM { unJunctionM :: ReaderT JunctionEnv IO a }
deriving (Functor, Applicative, Monad, MonadReader JunctionEnv, MonadIO, MonadThrow) deriving (Functor, Applicative, Monad, MonadReader JunctionEnv, MonadIO, MonadThrow)
instance HasLog JunctionEnv Message JunctionM where
getLogAction = peLogAction
setLogAction a e = e { peLogAction = a }
instance ConfigStorage JunctionM where instance ConfigStorage JunctionM where
loadConfig key = do loadConfig key = do
basePath <- asks peConfigPath basePath <- asks peConfigPath
@ -115,7 +129,7 @@ instance MonadPersistence JunctionM where
res <- liftIO $ runRedis conn $ mset [(encodeUtf8 key, BL.toStrict $ encode newState), res <- liftIO $ runRedis conn $ mset [(encodeUtf8 key, BL.toStrict $ encode newState),
(encodeUtf8 (key <> ":last_store") , encodeUtf8 . T.pack . show $ now)] (encodeUtf8 (key <> ":last_store") , encodeUtf8 . T.pack . show $ now)]
case res of case res of
Left _ -> liftIO $ warningM "main" "Unable to save state" Left _ -> logWarning "Junction " "Unable to save state"
Right _ -> return () Right _ -> return ()
loadState key = do loadState key = do
@ -124,17 +138,17 @@ instance MonadPersistence JunctionM where
-- TODO: just chain eithers -- TODO: just chain eithers
case res of case res of
Left _ -> do Left _ -> do
liftIO $ warningM "main" "Unable to load state" logWarning "Junction" "Unable to load state"
return def return def
Right maybeRawState -> Right maybeRawState ->
case maybeRawState of case maybeRawState of
Just rawState -> case eitherDecode $ BL.fromStrict rawState of Just rawState -> case eitherDecode $ BL.fromStrict rawState of
Left _ -> do Left _ -> do
liftIO $ warningM "main" "Unable to decode state" logWarning "Junction" "Unable to decode state"
return def return def
Right decodedState -> return decodedState Right decodedState -> return decodedState
Nothing -> do Nothing -> do
liftIO $ warningM "main" "Unable to decode state" logWarning "Junction" "Unable to decode state"
return def return def
instance QuoteStream JunctionM where instance QuoteStream JunctionM where
@ -148,18 +162,25 @@ junctionMain :: M.Map T.Text StrategyDescriptorE -> IO ()
junctionMain descriptors = do junctionMain descriptors = do
opts <- parseOptions opts <- parseOptions
let bootstrapLogAction = fmtMessage >$< logTextStdout
let log = logWith bootstrapLogAction
log Info "Junction" $ "Reading config from: " <> (T.pack . show) (configPath opts)
cfg <- readFile (configPath opts) >>= input auto cfg <- readFile (configPath opts) >>= input auto
barsMap <- newIORef M.empty barsMap <- newIORef M.empty
redis <- checkedConnect (defaultConnectInfo { connectPort = UnixSocket (T.unpack $ redisSocket cfg) }) redis <- checkedConnect (defaultConnectInfo { connectPort = UnixSocket (T.unpack $ redisSocket cfg) })
withContext $ \ctx -> do withContext $ \ctx -> do
let downloaderEnv = DownloaderEnv (mkQHPHandle ctx (qhpEndpoint cfg)) ctx (qtisEndpoint cfg) let downloaderLogAction = fmtMessage >$< logTextStdout
let downloaderEnv = DownloaderEnv (mkQHPHandle ctx (qhpEndpoint cfg)) ctx (qtisEndpoint cfg) downloaderLogAction
robotsMap <- newIORef M.empty robotsMap <- newIORef M.empty
ordersMap <- newIORef M.empty ordersMap <- newIORef M.empty
handledNotifications <- newIORef S.empty handledNotifications <- newIORef S.empty
withBroker cfg ctx robotsMap ordersMap handledNotifications $ \bro -> withBroker cfg ctx robotsMap ordersMap handledNotifications $ \bro ->
withQThread downloaderEnv barsMap cfg ctx $ \qt -> do withQThread downloaderEnv barsMap cfg ctx $ \qt -> do
let junctionLogAction = fmtMessage >$< logTextStdout
let env = let env =
JunctionEnv JunctionEnv
{ {
@ -167,7 +188,8 @@ junctionMain descriptors = do
peConfigPath = robotsConfigsPath cfg, peConfigPath = robotsConfigsPath cfg,
peQuoteThread = qt, peQuoteThread = qt,
peBroker = bro, peBroker = bro,
peRobots = robotsMap peRobots = robotsMap,
peLogAction = junctionLogAction
} }
withJunction env $ do withJunction env $ do
startRobots cfg bro barsMap startRobots cfg bro barsMap
@ -194,7 +216,8 @@ junctionMain descriptors = do
rConf <- liftIO $ newIORef (confStrategy bigConf) rConf <- liftIO $ newIORef (confStrategy bigConf)
rState <- loadState (stateKey inst) >>= liftIO . newIORef rState <- loadState (stateKey inst) >>= liftIO . newIORef
rTimers <- loadState (stateKey inst <> ":timers") >>= liftIO . newIORef rTimers <- loadState (stateKey inst <> ":timers") >>= liftIO . newIORef
let robotEnv = RobotEnv rState rConf rTimers bro barsMap let robotLogAction = fmtMessage >$< logTextStdout
let robotEnv = RobotEnv rState rConf rTimers bro barsMap robotLogAction
robot <- createRobotDriverThread inst desc (flip runReaderT robotEnv . unRobotM) bigConf rConf rState rTimers robot <- createRobotDriverThread inst desc (flip runReaderT robotEnv . unRobotM) bigConf rConf rState rTimers
robotsMap' <- asks peRobots robotsMap' <- asks peRobots
liftIO $ atomicModifyIORef' robotsMap' (\s -> (M.insert (strategyId inst) robot s, ())) liftIO $ atomicModifyIORef' robotsMap' (\s -> (M.insert (strategyId inst) robot s, ()))
@ -215,7 +238,7 @@ junctionMain descriptors = do
case getNotificationTarget robotsMap ordersMap notification of case getNotificationTarget robotsMap ordersMap notification of
Just robot -> postNotificationEvent robot notification Just robot -> postNotificationEvent robot notification
Nothing -> warningM "Junction" "Unknown order" Nothing -> return () --logWarning "Junction" "Unknown order" -- TODO log
atomicModifyIORef' handled (\s -> (S.insert (getNotificationSqnum notification) s, ())) atomicModifyIORef' handled (\s -> (S.insert (getNotificationSqnum notification) s, ()))

22
src/ATrade/Driver/Junction/QuoteThread.hs
Unescape View File

@ -1,7 +1,11 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
module ATrade.Driver.Junction.QuoteThread module ATrade.Driver.Junction.QuoteThread
( (
@ -17,6 +21,7 @@ module ATrade.Driver.Junction.QuoteThread
import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (..)) import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (..))
import ATrade.Driver.Junction.QuoteStream (QuoteSubscription (..)) import ATrade.Driver.Junction.QuoteStream (QuoteSubscription (..))
import ATrade.Logging (Message)
import ATrade.Quotes.HistoryProvider (HistoryProvider (..)) import ATrade.Quotes.HistoryProvider (HistoryProvider (..))
import ATrade.Quotes.QHP (QHPHandle, requestHistoryFromQHP) import ATrade.Quotes.QHP (QHPHandle, requestHistoryFromQHP)
import ATrade.Quotes.QTIS (TickerInfo (tiLotSize, tiTickSize, tiTicker), import ATrade.Quotes.QTIS (TickerInfo (tiLotSize, tiTickSize, tiTicker),
@ -36,13 +41,17 @@ import ATrade.Types (BarTimeframe (BarT
ClientSecurityParams (ClientSecurityParams), ClientSecurityParams (ClientSecurityParams),
Tick (security), Tick (security),
TickerId) TickerId)
import Colog (HasLog (getLogAction, setLogAction),
LogAction,
WithLog)
import Control.Concurrent (ThreadId, forkIO, import Control.Concurrent (ThreadId, forkIO,
killThread) killThread)
import Control.Concurrent.BoundedChan (BoundedChan, import Control.Concurrent.BoundedChan (BoundedChan,
newBoundedChan, newBoundedChan,
readChan, readChan,
writeChan) writeChan)
import Control.Exception.Safe (MonadThrow, import Control.Exception.Safe (MonadMask,
MonadThrow,
bracket) bracket)
import Control.Monad (forM, forever) import Control.Monad (forM, forever)
import Control.Monad.Reader (MonadIO (liftIO), ReaderT (runReaderT), import Control.Monad.Reader (MonadIO (liftIO), ReaderT (runReaderT),
@ -75,6 +84,7 @@ data QuoteThreadEnv =
startQuoteThread :: (MonadIO m, startQuoteThread :: (MonadIO m,
MonadIO m1, MonadIO m1,
WithLog DownloaderEnv Message m1,
HistoryProvider m1, HistoryProvider m1,
TickerInfoProvider m1) => TickerInfoProvider m1) =>
IORef Bars -> IORef Bars ->
@ -161,12 +171,17 @@ data DownloaderEnv =
{ {
qhp :: QHPHandle, qhp :: QHPHandle,
downloaderContext :: Context, downloaderContext :: Context,
downloaderQtisEndpoint :: T.Text downloaderQtisEndpoint :: T.Text,
logAction :: LogAction DownloaderM Message
} }
newtype DownloaderM a = DownloaderM { unDownloaderM :: ReaderT DownloaderEnv IO a } newtype DownloaderM a = DownloaderM { unDownloaderM :: ReaderT DownloaderEnv IO a }
deriving (Functor, Applicative, Monad, MonadReader DownloaderEnv, MonadIO, MonadThrow) deriving (Functor, Applicative, Monad, MonadReader DownloaderEnv, MonadIO, MonadThrow)
instance HasLog DownloaderEnv Message DownloaderM where
getLogAction = logAction
setLogAction a e = e { logAction = a }
instance HistoryProvider DownloaderM where instance HistoryProvider DownloaderM where
getHistory tid tf from to = do getHistory tid tf from to = do
q <- asks qhp q <- asks qhp
@ -176,7 +191,7 @@ instance TickerInfoProvider DownloaderM where
getInstrumentParameters tickers = do getInstrumentParameters tickers = do
ctx <- asks downloaderContext ctx <- asks downloaderContext
ep <- asks downloaderQtisEndpoint ep <- asks downloaderQtisEndpoint
tis <- liftIO $ forM tickers (qtisGetTickersInfo ctx ep) tis <- forM tickers (qtisGetTickersInfo ctx ep)
pure $ convert `fmap` tis pure $ convert `fmap` tis
where where
convert ti = InstrumentParameters convert ti = InstrumentParameters
@ -196,7 +211,6 @@ withQThread env barsMap cfg ctx f = do
(runDownloaderM env)) (runDownloaderM env))
stopQuoteThread f stopQuoteThread f
where where
loadSecurityParameters :: IO ClientSecurityParams
loadSecurityParameters = loadSecurityParameters =
case (quotesourceClientCert cfg, quotesourceServerCert cfg) of case (quotesourceClientCert cfg, quotesourceServerCert cfg) of
(Just clientCertPath, Just serverCertPath) -> do (Just clientCertPath, Just serverCertPath) -> do

15
src/ATrade/Driver/Junction/RobotDriverThread.hs
Unescape View File

@ -1,7 +1,9 @@
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
module ATrade.Driver.Junction.RobotDriverThread module ATrade.Driver.Junction.RobotDriverThread
@ -26,6 +28,7 @@ import ATrade.Driver.Junction.Types (BigConfig,
eventCallback, stateKey, eventCallback, stateKey,
strategyId, tickerId, strategyId, tickerId,
timeframe) timeframe)
import ATrade.Logging (Message, logInfo)
import ATrade.QuoteSource.Client (QuoteData (..)) import ATrade.QuoteSource.Client (QuoteData (..))
import ATrade.RoboCom.ConfigStorage (ConfigStorage) import ATrade.RoboCom.ConfigStorage (ConfigStorage)
import ATrade.RoboCom.Monad (Event (NewBar, NewTick, NewTrade, OrderUpdate), import ATrade.RoboCom.Monad (Event (NewBar, NewTick, NewTrade, OrderUpdate),
@ -34,6 +37,8 @@ import ATrade.RoboCom.Persistence (MonadPersistence)
import ATrade.RoboCom.Types (BarSeriesId (BarSeriesId), import ATrade.RoboCom.Types (BarSeriesId (BarSeriesId),
Bars) Bars)
import ATrade.Types (OrderId, OrderState, Trade) import ATrade.Types (OrderId, OrderState, Trade)
import Colog (HasLog (getLogAction, setLogAction),
LogAction)
import Control.Concurrent (ThreadId, forkIO) import Control.Concurrent (ThreadId, forkIO)
import Control.Concurrent.BoundedChan (BoundedChan, import Control.Concurrent.BoundedChan (BoundedChan,
newBoundedChan, readChan, newBoundedChan, readChan,
@ -50,7 +55,6 @@ import qualified Data.Map.Strict as M
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Dhall (FromDhall) import Dhall (FromDhall)
import System.Log.Logger (infoM)
data RobotDriverHandle = forall c s. (FromDhall c, Default s, FromJSON s, ToJSON s) => data RobotDriverHandle = forall c s. (FromDhall c, Default s, FromJSON s, ToJSON s) =>
RobotDriverHandle (StrategyInstance c s) ThreadId ThreadId (BoundedChan RobotDriverEvent) RobotDriverHandle (StrategyInstance c s) ThreadId ThreadId (BoundedChan RobotDriverEvent)
@ -127,12 +131,17 @@ data RobotEnv c s =
configRef :: IORef c, configRef :: IORef c,
timersRef :: IORef [UTCTime], timersRef :: IORef [UTCTime],
broker :: BrokerClientHandle, broker :: BrokerClientHandle,
bars :: IORef Bars bars :: IORef Bars,
logAction :: LogAction (RobotM c s) Message
} }
newtype RobotM c s a = RobotM { unRobotM :: ReaderT (RobotEnv c s) IO a } newtype RobotM c s a = RobotM { unRobotM :: ReaderT (RobotEnv c s) IO a }
deriving (Functor, Applicative, Monad, MonadReader (RobotEnv c s), MonadIO, MonadThrow) deriving (Functor, Applicative, Monad, MonadReader (RobotEnv c s), MonadIO, MonadThrow)
instance HasLog (RobotEnv c s) Message (RobotM c s) where
getLogAction = logAction
setLogAction a e = e { logAction = a }
instance MonadRobot (RobotM c s) c s where instance MonadRobot (RobotM c s) c s where
submitOrder order = do submitOrder order = do
bro <- asks broker bro <- asks broker
@ -142,7 +151,7 @@ instance MonadRobot (RobotM c s) c s where
bro <- asks broker bro <- asks broker
liftIO $ void $ Bro.cancelOrder bro oid liftIO $ void $ Bro.cancelOrder bro oid
appendToLog = liftIO . infoM "Robot" . TL.unpack appendToLog = logInfo "RobotM" . TL.toStrict -- TODO get instance id from environment and better use it instead of generic 'RobotM'
setupTimer t = do setupTimer t = do
ref <- asks timersRef ref <- asks timersRef

5
src/ATrade/Quotes/Finam.hs
Unescape View File

@ -18,10 +18,12 @@ module ATrade.Quotes.Finam (
) where ) where
import ATrade.Types import ATrade.Types
import Colog (HasLog, Msg)
import Control.Error.Util import Control.Error.Util
import Control.Exception import Control.Exception
import Control.Lens import Control.Lens
import Control.Monad import Control.Monad
import Control.Monad.IO.Class (MonadIO)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
@ -37,7 +39,6 @@ import Data.Time.Format
import qualified Data.Vector as V import qualified Data.Vector as V
import Network.Wreq import Network.Wreq
import Safe import Safe
import System.Log.Logger
import Text.Parsec import Text.Parsec
import Text.ParserCombinators.Parsec.Number import Text.ParserCombinators.Parsec.Number
@ -209,7 +210,7 @@ instance FromRecord Row where
Just dt -> return dt Just dt -> return dt
Nothing -> fail "Unable to parse date/time" Nothing -> fail "Unable to parse date/time"
downloadAndParseQuotes :: RequestParams -> IO (Maybe [Row]) downloadAndParseQuotes :: (MonadIO m, HasLog env Msg m)RequestParams -> IO (Maybe [Row])
downloadAndParseQuotes requestParams = downloadAndParseQuotes' 3 downloadAndParseQuotes requestParams = downloadAndParseQuotes' 3
where where
downloadAndParseQuotes' iter = do downloadAndParseQuotes' iter = do

18
src/ATrade/Quotes/QHP.hs
Unescape View File

@ -1,4 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module ATrade.Quotes.QHP ( module ATrade.Quotes.QHP (
Period(..), Period(..),
@ -9,7 +11,9 @@ module ATrade.Quotes.QHP (
) where ) where
import ATrade.Exceptions import ATrade.Exceptions
import ATrade.Logging (Message, logInfo)
import ATrade.Types import ATrade.Types
import Colog (WithLog)
import Control.Exception.Safe (MonadThrow, throw) import Control.Exception.Safe (MonadThrow, throw)
import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson import Data.Aeson
@ -20,7 +24,7 @@ import Data.Time.Calendar
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import Data.Time.Format import Data.Time.Format
import System.Log.Logger import Language.Haskell.Printf (t)
import System.ZMQ4 import System.ZMQ4
data Period = data Period =
@ -53,10 +57,10 @@ data QHPHandle = QHPHandle
mkQHPHandle :: Context -> T.Text -> QHPHandle mkQHPHandle :: Context -> T.Text -> QHPHandle
mkQHPHandle = QHPHandle mkQHPHandle = QHPHandle
requestHistoryFromQHP :: (MonadThrow m, MonadIO m) => QHPHandle -> TickerId -> BarTimeframe -> UTCTime -> UTCTime -> m [Bar] requestHistoryFromQHP :: (WithLog env Message m, MonadThrow m, MonadIO m) => QHPHandle -> TickerId -> BarTimeframe -> UTCTime -> UTCTime -> m [Bar]
requestHistoryFromQHP qhp tickerId timeframe fromTime toTime = requestHistoryFromQHP qhp tickerId timeframe fromTime toTime =
case parseQHPPeriod (unBarTimeframe timeframe) of case parseQHPPeriod (unBarTimeframe timeframe) of
Just tf -> liftIO $ getQuotes (qhpContext qhp) (params tf) Just tf -> getQuotes (qhpContext qhp) (params tf)
_ -> throw $ BadParams "QHP: Unable to parse timeframe" _ -> throw $ BadParams "QHP: Unable to parse timeframe"
where where
params tf = RequestParams params tf = RequestParams
@ -96,10 +100,10 @@ instance ToJSON RequestParams where
"to" .= printDatetime (UTCTime (endDate p) 0), "to" .= printDatetime (UTCTime (endDate p) 0),
"timeframe" .= show (period p) ] "timeframe" .= show (period p) ]
getQuotes :: Context -> RequestParams -> IO [Bar] getQuotes :: (WithLog env Message m, MonadIO m) => Context -> RequestParams -> m [Bar]
getQuotes ctx params = getQuotes ctx params = do
withSocket ctx Req $ \sock -> do logInfo "QHP" $ "Connecting to ep: " <> endpoint params
debugM "QHP" $ "Connecting to ep: " ++ show (endpoint params) liftIO $ withSocket ctx Req $ \sock -> do
connect sock $ (T.unpack . endpoint) params connect sock $ (T.unpack . endpoint) params
send sock [] (BL.toStrict $ encode params) send sock [] (BL.toStrict $ encode params)
response <- receiveMulti sock response <- receiveMulti sock

15
src/ATrade/Quotes/QTIS.hs
Unescape View File

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module ATrade.Quotes.QTIS module ATrade.Quotes.QTIS
@ -7,13 +8,15 @@ module ATrade.Quotes.QTIS
) where ) where
import ATrade.Exceptions import ATrade.Exceptions
import ATrade.Logging (Message, logInfo)
import ATrade.Types import ATrade.Types
import Colog (WithLog)
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Aeson import Data.Aeson
import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T import qualified Data.Text as T
import System.Log.Logger
import System.ZMQ4 import System.ZMQ4
data TickerInfo = TickerInfo { data TickerInfo = TickerInfo {
@ -34,16 +37,14 @@ instance ToJSON TickerInfo where
"lot_size" .= tiLotSize ti, "lot_size" .= tiLotSize ti,
"tick_size" .= tiTickSize ti ] "tick_size" .= tiTickSize ti ]
qtisGetTickersInfo :: Context -> T.Text -> TickerId -> IO TickerInfo qtisGetTickersInfo :: (WithLog env Message m, MonadIO m) => Context -> T.Text -> TickerId -> m TickerInfo
qtisGetTickersInfo ctx endpoint tickerId = qtisGetTickersInfo ctx endpoint tickerId = do
withSocket ctx Req $ \sock -> do logInfo "QTIS" $ "Requesting ticker: " <> tickerId <> " from " <> endpoint
debugM "QTIS" $ "Connecting to: " ++ T.unpack endpoint liftIO $ withSocket ctx Req $ \sock -> do
connect sock $ T.unpack endpoint connect sock $ T.unpack endpoint
debugM "QTIS" $ "Requesting: " ++ T.unpack tickerId
send sock [] $ BL.toStrict tickerRequest send sock [] $ BL.toStrict tickerRequest
response <- receiveMulti sock response <- receiveMulti sock
let r = parseResponse response let r = parseResponse response
debugM "QTIS" $ "Got response: " ++ show r
case r of case r of
Just resp -> return resp Just resp -> return resp
Nothing -> throw $ QTISFailure "Can't parse response" Nothing -> throw $ QTISFailure "Can't parse response"

2
stack.yaml
Unescape View File

@ -48,6 +48,8 @@ extra-deps:
- binary-ieee754-0.1.0.0 - binary-ieee754-0.1.0.0
- th-printf-0.7 - th-printf-0.7
- normaldistribution-1.1.0.3 - normaldistribution-1.1.0.3
- co-log-0.4.0.1@sha256:3d4c17f37693c80d1aa2c41669bc3438fac3e89dc5f479e57d79bc3ddc4dfcc5,5087
- ansi-terminal-0.10.3@sha256:e2fbcef5f980dc234c7ad8e2fa433b0e8109132c9e643bc40ea5608cd5697797,3226
# Override default flag values for local packages and extra-deps # Override default flag values for local packages and extra-deps
# flags: {} # flags: {}

Write Preview
Loading…
Cancel
Save