diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index 2d75ea2..cd4ad8e 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -1,11 +1,9 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module ATrade.Driver.Junction ( @@ -17,8 +15,7 @@ import ATrade.Broker.Client (startBrokerClient, import ATrade.Broker.Protocol (Notification (OrderNotification, TradeNotification), NotificationSqnum (unNotificationSqnum), getNotificationSqnum) -import ATrade.Driver.Junction.BrokerService (BrokerService, - getNotifications, +import ATrade.Driver.Junction.BrokerService (getNotifications, mkBrokerService) import ATrade.Driver.Junction.JunctionMonad (JunctionEnv (..), JunctionM (..), @@ -30,23 +27,14 @@ import ATrade.Driver.Junction.QuoteThread (DownloaderEnv (Dow withQThread) import ATrade.Driver.Junction.RemoteControl (handleRemoteControl) import ATrade.Driver.Junction.RobotDriverThread (RobotDriverHandle, postNotificationEvent) -import ATrade.Driver.Junction.Types (StrategyDescriptorE, - confStrategy, - confTickers, - strategyState, - strategyTimers, - tickerId, - timeframe) -import ATrade.Logging (Message, Severity (Debug, Info, Trace, Warning), +import ATrade.Driver.Junction.Types (StrategyDescriptorE) +import ATrade.Logging (Message (..), Severity (Debug, Info, Trace, Warning), fmtMessage, logWith) import ATrade.Quotes.QHP (mkQHPHandle) -import ATrade.RoboCom.Types (Bars, - TickerInfoMap) -import ATrade.Types (ClientSecurityParams (ClientSecurityParams), - OrderId, - Trade (tradeOrderId)) +import ATrade.Types (OrderId, Trade (tradeOrderId)) import Colog (LogAction (LogAction), + cfilter, hoistLogAction, logTextStdout, (<&), (>$<)) @@ -64,7 +52,6 @@ import qualified Data.Map.Strict as M import Data.Set (notMember) import qualified Data.Set as S import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) import Data.Text.IO (readFile) import Database.Redis (ConnectInfo (..), PortID (UnixSocket), checkedConnect, @@ -88,7 +75,6 @@ import System.IO (BufferMode (LineBu import System.ZMQ4 (Router (Router), bind, withContext, withSocket) -import System.ZMQ4.ZAP (loadCertificateFromFile) import UnliftIO (MonadUnliftIO) import UnliftIO.Exception (bracket) import UnliftIO.QSem (QSem, withQSem) @@ -97,8 +83,13 @@ import UnliftIO.QSem (QSem, withQSem) locked :: (MonadIO m, MonadUnliftIO m) => QSem -> LogAction m a -> LogAction m a locked sem action = LogAction (\m -> withQSem sem (action <& m)) -logger :: (MonadIO m) => Handle -> LogAction m Message -logger h = fmtMessage >$< (logTextStdout <> logTextHandle h) +logger :: (MonadIO m) => M.Map T.Text Severity -> Handle -> LogAction m Message +logger loglevels h = cfilter checkLoglevel (fmtMessage >$< (logTextStdout <> logTextHandle h)) + where + checkLoglevel msg = + case M.lookup (msgComponent msg) loglevels of + Just level -> msgSeverity msg >= level + Nothing -> True junctionMain :: M.Map T.Text StrategyDescriptorE -> IO () junctionMain descriptors = do @@ -115,7 +106,7 @@ junctionMain descriptors = do hSetBuffering h LineBuffering locksem <- newQSem 1 - let globalLogger = locked locksem (logger h) + let globalLogger = locked locksem (logger (M.fromList $ logLevels cfg) h) let log = logWith globalLogger barsMap <- newIORef M.empty @@ -130,7 +121,7 @@ junctionMain descriptors = do robotsMap <- newIORef M.empty ordersMap <- newIORef M.empty handledNotifications <- newIORef S.empty - withBroker cfg ctx robotsMap ordersMap handledNotifications globalLogger $ \bro -> + withBroker cfg robotsMap ordersMap handledNotifications globalLogger $ \bro -> withQThread downloaderEnv barsMap tickerInfoMap cfg ctx globalLogger $ \qt -> withSocket ctx Router $ \rcSocket -> do liftIO $ bind rcSocket (T.unpack . remoteControlEndpoint $ cfg) @@ -195,8 +186,7 @@ junctionMain descriptors = do notificationOrderId (OrderNotification _ oid _) = oid notificationOrderId (TradeNotification _ trade) = tradeOrderId trade - withBroker cfg ctx robotsMap ordersMap handled logger' f = do - securityParameters <- loadBrokerSecurityParameters cfg + withBroker cfg robotsMap ordersMap handled logger' f = do bracket (startBrokerClient (brokerIdentity cfg) @@ -205,17 +195,6 @@ junctionMain descriptors = do logger') stopBrokerClient f - loadBrokerSecurityParameters cfg = - case (brokerClientCert cfg, brokerServerCert cfg) of - (Just clientCertPath, Just serverCertPath) -> do - eClientCert <- loadCertificateFromFile clientCertPath - eServerCert <- loadCertificateFromFile serverCertPath - case (eClientCert, eServerCert) of - (Right clientCert, Right serverCert) -> return $ ClientSecurityParams (Just clientCert) (Just serverCert) - (_, _) -> return $ ClientSecurityParams Nothing Nothing - - _ -> return $ ClientSecurityParams Nothing Nothing - parseOptions = execParser options options = info (optionsParser <**> helper) (fullDesc <> diff --git a/src/ATrade/Driver/Junction/ProgramConfiguration.hs b/src/ATrade/Driver/Junction/ProgramConfiguration.hs index cc4b33e..d4057ae 100644 --- a/src/ATrade/Driver/Junction/ProgramConfiguration.hs +++ b/src/ATrade/Driver/Junction/ProgramConfiguration.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module ATrade.Driver.Junction.ProgramConfiguration ( @@ -6,8 +9,12 @@ module ATrade.Driver.Junction.ProgramConfiguration ProgramConfiguration(..) ) where import ATrade.Driver.Junction.Types (StrategyInstanceDescriptor) +import ATrade.Logging (Severity (..)) import qualified Data.Text as T -import Dhall (FromDhall) +import Dhall (FromDhall, autoWith) +import Dhall.Core (Expr (..), FieldSelection (..)) +import qualified Dhall.Map +import Dhall.Marshal.Decode (Decoder (..), typeError) import GHC.Generics (Generic) newtype ProgramOptions = @@ -33,7 +40,33 @@ data ProgramConfiguration = redisSocket :: T.Text, robotsConfigsPath :: FilePath, logBasePath :: FilePath, + logLevels :: [(T.Text, Severity)], instances :: [StrategyInstanceDescriptor] } deriving (Generic, Show) +instance FromDhall Severity where + autoWith _ = Decoder {..} + where + extract expr@(Field _ FieldSelection{ fieldSelectionLabel }) = + case fieldSelectionLabel of + "Trace" -> pure Trace + "Debug" -> pure Debug + "Info" -> pure Info + "Warning" -> pure Warning + "Error" -> pure Error + _ -> typeError expected expr + extract expr = typeError expected expr + + expected = pure + (Union + (Dhall.Map.fromList + [ ("Trace", Nothing) + , ("Debug", Nothing) + , ("Info", Nothing) + , ("Warning", Nothing) + , ("Error", Nothing) + ] + ) + ) + instance FromDhall ProgramConfiguration