Logging

app/Main.hs

@@ -2,8 +2,8 @@
 module Main where
 
 import           Data.Aeson
-import qualified Data.Text as T
 import qualified Data.ByteString.Lazy      as BL
+import qualified Data.Text                 as T
 
 import           ATrade.MDS.Database
 import           ATrade.MDS.HistoryServer
@@ -11,8 +11,14 @@ import ATrade.MDS.HistoryServer
 import           Control.Concurrent
 import           Control.Monad
 
+import           System.IO
+import           System.Log.Formatter
+import           System.Log.Handler        (setFormatter)
+import           System.Log.Handler.Simple
+import           System.Log.Logger
 import           System.ZMQ4
 
+
 data MdsConfig = MdsConfig {
   cfgDbPath      :: T.Text,
   cfgDbName      :: T.Text,
@@ -32,6 +38,16 @@ instance FromJSON MdsConfig where
       v .: "qhp_endpoint" <*>
       v .: "hap_endpoint"
 
+initLogging :: IO ()
+initLogging = do
+  handler <- fileHandler "mds.log" DEBUG >>=
+    (\x -> return $
+      setFormatter x (simpleLogFormatter "$utcTime\t {$loggername} <$prio> -> $msg"))
+
+  hSetBuffering stderr LineBuffering
+  updateGlobalLogger rootLoggerName (setLevel DEBUG)
+  updateGlobalLogger rootLoggerName (setHandlers [handler])
+
 getConfig :: IO MdsConfig
 getConfig = do
   rawCfg <- BL.readFile "mds.conf"
@@ -41,18 +57,23 @@ getConfig = do
 
 main :: IO ()
 main = do
+  initLogging
+  debugM "main" "Initializing MDS"
   cfg <- getConfig
+  debugM "main" "Config OK"
   let dbConfig = DatabaseConfig { dbPath = cfgDbPath cfg,
     dbDatabase = cfgDbName cfg,
     dbUser = cfgDbAccount cfg,
     dbPassword = cfgDbPassword cfg }
 
   db <- initDatabase dbConfig
+  debugM "main" "DB initialized"
 
   let hsConfig = HistoryServerConfig {
     hspQHPEndpoint = cfgQHPEndpoint cfg,
     hspHAPEndpoint = cfgHAPEndpoint cfg }
 
+  debugM "main" "Starting history server"
   withContext $ \ctx -> do
     _ <- startHistoryServer hsConfig db ctx
     forever $ threadDelay 1000000

mds.cabal

@@ -49,6 +49,7 @@ executable mds-exe
                      , aeson
                      , text
                      , bytestring
+                     , hslogger
                      , zeromq4-haskell
   default-language:    Haskell2010
   default-extensions:  OverloadedStrings

src/ATrade/MDS/Database.hs

@@ -14,19 +14,18 @@ module ATrade.MDS.Database (
   timeframeMinute
 ) where
 
-import qualified Data.Text as T
-import qualified Data.Vector as V
 import           ATrade.Types
+import           Control.Monad
+import           Data.Maybe
+import qualified Data.Text             as T
 import           Data.Time.Clock
 import           Data.Time.Clock.POSIX
-import Data.Maybe
+import qualified Data.Vector           as V
 import           Database.HDBC
 import           Database.HDBC.Sqlite3
-import Control.Monad
 
 
 data TimeInterval = TimeInterval UTCTime UTCTime
-
 data Timeframe = Timeframe Int
 
 timeframeDaily :: Int -> Timeframe

src/ATrade/MDS/HistoryServer.hs

@@ -21,6 +21,8 @@ import qualified Data.Text             as T
 import           Data.Time.Clock.POSIX
 import qualified Data.Vector           as V
 import           Safe
+
+import           System.Log.Logger
 import           System.ZMQ4
 
 data HistoryServer = HistoryServer ThreadId ThreadId
@@ -53,6 +55,7 @@ serveQHP db sock = forever $ do
     handleCmd :: B.ByteString -> QHPRequest -> IO ()
     handleCmd peerId cmd = case cmd of
       rq -> do
+        debugM "QHP" $ "Incoming command: " ++ show cmd
         qdata <- getData db (rqTicker rq) (TimeInterval (rqStartTime rq) (rqEndTime rq)) (Timeframe (periodSeconds $ rqPeriod rq))
         let bytes = serializeBars $ V.concat $ fmap snd qdata
         sendMulti sock $ peerId :| B.empty : [BL.toStrict bytes]
@@ -79,6 +82,7 @@ serveHAP db sock = forever $ do
   where
     handleCmd :: B.ByteString -> HAPRequest -> [Bar] -> IO ()
     handleCmd peerId rq bars = do
+      debugM "HAP" $ "Incoming command: " ++ show rq
       putData db (hapTicker rq) (TimeInterval (hapStartTime rq) (hapEndTime rq)) (Timeframe $ hapTimeframeSec rq) (V.fromList bars)
       sendMulti sock $ peerId :| B.empty : ["OK"]