Junction: per-component configurable log levels

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 <>

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