|
|
|
|
|
|
|
|
|
module Main where
|
|
|
|
|
|
|
|
|
|
import Data.Aeson
|
|
|
|
|
import qualified Data.ByteString.Lazy as BL
|
|
|
|
|
import qualified Data.Text as T
|
|
|
|
|
|
|
|
|
|
import ATrade.MDS.Database
|
|
|
|
|
import ATrade.MDS.HistoryServer
|
|
|
|
|
|
|
|
|
|
import Control.Concurrent
|
|
|
|
|
import Control.Monad
|
|
|
|
|
|
|
|
|
|
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,
|
|
|
|
|
cfgDbAccount :: T.Text,
|
|
|
|
|
cfgDbPassword :: T.Text,
|
|
|
|
|
cfgQHPEndpoint :: T.Text,
|
|
|
|
|
cfgHAPEndpoint :: T.Text
|
|
|
|
|
} deriving (Show, Eq)
|
|
|
|
|
|
|
|
|
|
instance FromJSON MdsConfig where
|
|
|
|
|
parseJSON = withObject "Cfg" $ \v ->
|
|
|
|
|
MdsConfig <$>
|
|
|
|
|
v .: "path" <*>
|
|
|
|
|
v .: "name" <*>
|
|
|
|
|
v .: "account" <*>
|
|
|
|
|
v .: "password" <*>
|
|
|
|
|
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"))
|
|
|
|
|
|
|
|
|
|
updateGlobalLogger rootLoggerName (setLevel DEBUG)
|
|
|
|
|
updateGlobalLogger rootLoggerName (setHandlers [handler])
|
|
|
|
|
|
|
|
|
|
getConfig :: IO MdsConfig
|
|
|
|
|
getConfig = do
|
|
|
|
|
rawCfg <- BL.readFile "mds.conf"
|
|
|
|
|
case eitherDecode' rawCfg of
|
|
|
|
|
Left err -> error err
|
|
|
|
|
Right cfg -> return cfg
|
|
|
|
|
|
|
|
|
|
main :: IO ()
|
|
|
|
|
main = do
|
|
|
|
|
initLogging
|
|
|
|
|
infoM "main" "Initializing MDS"
|
|
|
|
|
cfg <- getConfig
|
|
|
|
|
infoM "main" "Config OK"
|
|
|
|
|
let dbConfig = DatabaseConfig { dbPath = cfgDbPath cfg,
|
|
|
|
|
dbDatabase = cfgDbName cfg,
|
|
|
|
|
dbUser = cfgDbAccount cfg,
|
|
|
|
|
dbPassword = cfgDbPassword cfg }
|
|
|
|
|
|
|
|
|
|
db <- initDatabase dbConfig
|
|
|
|
|
infoM "main" "DB initialized"
|
|
|
|
|
|
|
|
|
|
let hsConfig = HistoryServerConfig {
|
|
|
|
|
hspQHPEndpoint = cfgQHPEndpoint cfg,
|
|
|
|
|
hspHAPEndpoint = cfgHAPEndpoint cfg }
|
|
|
|
|
|
|
|
|
|
infoM "main" "Starting history server"
|
|
|
|
|
withContext $ \ctx -> do
|
|
|
|
|
_ <- startHistoryServer hsConfig db ctx
|
|
|
|
|
forever $ threadDelay 1000000
|
|
|
|
|
|