Cleanup

app/Config.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE OverloadedStrings, OverloadedLabels #-}
+
+module Config (
+  TableConfig(..),
+  Config(..),
+  readConfig
+
+) where 
+
+import Data.Aeson
+import Data.Aeson.Types
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Vector as V
+import qualified Data.Text as T
+
+data TableConfig = TableConfig {
+  parserId :: String,
+  tableName :: String,
+  tableParams :: Value
+} deriving (Show)
+
+data Config = Config {
+  quotesourceEndpoint :: String,
+  brokerserverEndpoint :: String,
+  whitelist :: [T.Text],
+  blacklist :: [T.Text],
+  brokerServerCertPath :: Maybe FilePath,
+  brokerClientCertificateDir :: Maybe FilePath,
+  tables :: [TableConfig],
+  quikPath :: String,
+  dllPath :: String,
+  quikAccounts :: [T.Text],
+  tradeSink :: T.Text,
+  telegramToken :: T.Text,
+  telegramChatId :: T.Text
+} deriving (Show)
+
+readConfig :: String -> IO Config
+readConfig fname = do
+  content <- BL.readFile fname
+  case decode content >>= parseMaybe parseConfig of
+    Just config -> return config
+    Nothing -> error "Unable to load config"
+
+parseConfig :: Value -> Parser Config
+parseConfig = withObject "object" $ \obj -> do
+  qse <- obj .: "quotesource-endpoint"
+  bse <- obj .: "brokerserver-endpoint"
+  whitelist' <- obj .:? "whitelist" .!= []
+  blacklist' <- obj .:? "blacklist" .!= []
+  serverCert <- obj .:? "broker_server_certificate"
+  clientCerts <- obj .:? "broker_client_certificates"
+  rt <- case HM.lookup "tables" obj of
+    Just v -> parseTables v
+    Nothing -> fail "Expected tables array"
+  qp <- obj .: "quik-path"
+  dp <- obj .: "dll-path"
+  trsink <- obj .: "trade-sink"
+  tgToken <- obj .: "telegram-token"
+  tgChatId <- obj .: "telegram-chatid"
+  accs <- V.toList <$> obj .: "accounts"
+  return Config { quotesourceEndpoint = qse,
+    brokerserverEndpoint = bse,
+    whitelist = whitelist',
+    blacklist = blacklist',
+    brokerServerCertPath = serverCert,
+    brokerClientCertificateDir = clientCerts,
+    tables = rt,
+    quikPath = qp,
+    dllPath = dp,
+    quikAccounts = fmap T.pack accs,
+    tradeSink = trsink,
+    telegramToken = tgToken,
+    telegramChatId = tgChatId }
+  where
+    parseTables :: Value -> Parser [TableConfig]
+    parseTables = withArray "array" $ \arr -> mapM parseTableConfig (V.toList arr)
+
+    parseTableConfig :: Value -> Parser TableConfig
+    parseTableConfig = withObject "object" $ \obj -> do
+      pid <- obj .: "parser-id"
+      tn <- obj .: "table-name"
+      params <- case HM.lookup "params" obj of
+        Just x -> return x
+        Nothing -> return $ Object HM.empty
+      return TableConfig {
+        parserId = pid,
+        tableName = tn,
+        tableParams = params }
+

app/Main.hs

@@ -8,8 +8,6 @@ import Control.Concurrent hiding (readChan, writeChan)
 import Control.Monad
 import Control.Exception
 import Control.Error.Util
-import Control.Monad.IO.Class
-import Data.IORef
 import qualified GI.Gtk as Gtk
 import Data.GI.Base
 import Control.Concurrent.BoundedChan
@@ -21,7 +19,6 @@ import ATrade.QuoteSource.Server
 import ATrade.Broker.TradeSinks.ZMQTradeSink
 import ATrade.Broker.TradeSinks.TelegramTradeSink
 import ATrade.Broker.Server
-import ATrade.Broker.Protocol
 import Broker.PaperBroker
 import Broker.QuikBroker
 
@@ -34,109 +31,26 @@ import System.Log.Formatter
 import System.ZMQ4
 import System.ZMQ4.ZAP
 
-import Data.Aeson
-import Data.Aeson.Types
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.HashMap.Strict as HM
-import qualified Data.Vector as V
 import qualified Data.Text as T
 import Data.Maybe
 
 import Control.Monad.Trans.Except
-import Broker.QuikBroker.Trans2QuikApi
-
-import Network.Telegram
-import Network.Connection
-import Network.HTTP.Client
-import Network.HTTP.Client.TLS
-
-data TableConfig = TableConfig {
-  parserId :: String,
-  tableName :: String,
-  tableParams :: Value
-} deriving (Show)
-
-data Config = Config {
-  quotesourceEndpoint :: String,
-  brokerserverEndpoint :: String,
-  whitelist :: [T.Text],
-  blacklist :: [T.Text],
-  brokerServerCertPath :: Maybe FilePath,
-  brokerClientCertificateDir :: Maybe FilePath,
-  tables :: [TableConfig],
-  quikPath :: String,
-  dllPath :: String,
-  quikAccounts :: [T.Text],
-  tradeSink :: T.Text,
-  telegramToken :: T.Text,
-  telegramChatId :: T.Text
-} deriving (Show)
-
-readConfig :: String -> IO Config
-readConfig fname = do
-  content <- BL.readFile fname
-  case decode content >>= parseMaybe parseConfig of
-    Just config -> return config
-    Nothing -> error "Unable to load config"
-
-parseConfig :: Value -> Parser Config
-parseConfig = withObject "object" $ \obj -> do
-  qse <- obj .: "quotesource-endpoint"
-  bse <- obj .: "brokerserver-endpoint"
-  whitelist' <- obj .:? "whitelist" .!= []
-  blacklist' <- obj .:? "blacklist" .!= []
-  serverCert <- obj .:? "broker_server_certificate"
-  clientCerts <- obj .:? "broker_client_certificates"
-  rt <- case HM.lookup "tables" obj of
-    Just v -> parseTables v
-    Nothing -> fail "Expected tables array"
-  qp <- obj .: "quik-path"
-  dp <- obj .: "dll-path"
-  trsink <- obj .: "trade-sink"
-  tgToken <- obj .: "telegram-token"
-  tgChatId <- obj .: "telegram-chatid"
-  accs <- V.toList <$> obj .: "accounts"
-  return Config { quotesourceEndpoint = qse,
-    brokerserverEndpoint = bse,
-    whitelist = whitelist',
-    blacklist = blacklist',
-    brokerServerCertPath = serverCert,
-    brokerClientCertificateDir = clientCerts,
-    tables = rt,
-    quikPath = qp,
-    dllPath = dp,
-    quikAccounts = fmap T.pack accs,
-    tradeSink = trsink,
-    telegramToken = tgToken,
-    telegramChatId = tgChatId }
-  where
-    parseTables :: Value -> Parser [TableConfig]
-    parseTables = withArray "array" $ \arr -> mapM parseTableConfig (V.toList arr)
-
-    parseTableConfig :: Value -> Parser TableConfig
-    parseTableConfig = withObject "object" $ \obj -> do
-      pid <- obj .: "parser-id"
-      tn <- obj .: "table-name"
-      params <- case HM.lookup "params" obj of
-        Just x -> return x
-        Nothing -> return $ Object HM.empty
-      return TableConfig {
-        parserId = pid,
-        tableName = tn,
-        tableParams = params }
+
+import Config
 
 forkBoundedChan :: Int -> BoundedChan Tick -> IO (ThreadId, BoundedChan Tick, BoundedChan QuoteSourceServerData)
-forkBoundedChan size source = do
+forkBoundedChan size sourceChan = do
   sink <- newBoundedChan size
   sinkQss <- newBoundedChan size
   tid <- forkIO $ forever $ do
-      v <- readChan source
+      v <- readChan sourceChan
       writeChan sink v
       writeChan sinkQss (QSSTick v)
 
   return (tid, sink, sinkQss)
 
 
+initLogging :: IO ()
 initLogging = do
   handler <- streamHandler stderr DEBUG >>=
     (\x -> return $
@@ -155,14 +69,12 @@ main = do
   infoM "main" "Config loaded"
   chan <- newBoundedChan 10000
   infoM "main" "Starting data import server"
-  dis <- initDataImportServer [MkTableParser $ mkAllParamsTableParser "allparams"] chan "atrade"
+  _ <- initDataImportServer [MkTableParser $ mkAllParamsTableParser "allparams"] chan "atrade"
 
   (forkId, c1, c2) <- forkBoundedChan 10000 chan
 
   broker <- mkPaperBroker c1 1000000 ["demo"]
-  man <- newManager (mkManagerSettings (TLSSettingsSimple { settingDisableCertificateValidation = True, settingDisableSession = False, settingUseServerName = False }) Nothing)
-  infoM "main" "Http manager created"
-  eitherBrokerQ <- runExceptT $ mkQuikBroker man (dllPath config) (quikPath config) (quikAccounts config)
+  eitherBrokerQ <- runExceptT $ mkQuikBroker (dllPath config) (quikPath config) (quikAccounts config)
   case eitherBrokerQ of
     Left errmsg -> warningM "main" $ "Can't load quik broker: " ++ T.unpack errmsg
     Right brokerQ ->
@@ -172,8 +84,8 @@ main = do
           zapSetBlacklist zap $ blacklist config
 
           case brokerClientCertificateDir config of
-            Just path -> do
-              certs <- loadCertificatesFromDirectory path
+            Just certFile -> do
+              certs <- loadCertificatesFromDirectory certFile
               forM_ certs (\cert -> zapAddClientCertificate zap cert)
             Nothing -> return ()
 
@@ -181,8 +93,8 @@ main = do
             Just certFile -> do
               eitherCert <- loadCertificateFromFile certFile
               case eitherCert of
-                Left err -> do
-                  warningM "main" $ "Unable to load server certificate: " ++ err
+                Left errorMessage -> do
+                  warningM "main" $ "Unable to load server certificate: " ++ errorMessage
                   return Nothing
                 Right cert -> return $ Just cert
             Nothing -> return Nothing
@@ -191,11 +103,11 @@ main = do
 
           withZMQTradeSink ctx (tradeSink config) (\zmqTradeSink -> do
             withTelegramTradeSink (telegramToken config) (telegramChatId config) (\telegramTradeSink -> do
-              bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config)) stopQuoteSourceServer (\qsServer -> do
-                bracket (startBrokerServer [broker, brokerQ] ctx (T.pack $ brokerserverEndpoint config) [telegramTradeSink, zmqTradeSink] serverParams) stopBrokerServer (\broServer -> do
-                  Gtk.init Nothing
+              bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config)) stopQuoteSourceServer (\_ -> do
+                bracket (startBrokerServer [broker, brokerQ] ctx (T.pack $ brokerserverEndpoint config) [telegramTradeSink, zmqTradeSink] serverParams) stopBrokerServer (\_ -> do
+                  void $ Gtk.init Nothing
                   window <- new Gtk.Window [ #title := "Quik connector" ]
-                  on window #destroy Gtk.mainQuit
+                  void $ on window #destroy Gtk.mainQuit
                   #showAll window
                   Gtk.main)
                 infoM "main" "BRS down")
@@ -203,10 +115,11 @@ main = do
             debugM "main" "TGTS done")
           debugM "main" "ZMQTS done")
         debugM "main" "ZAP done")
-  timeout 1000000 $ killThread forkId
+  void $ timeout 1000000 $ killThread forkId
   infoM "main" "Main thread done"
 
-loadCertificatesFromDirectory path = do
-  files <- listDirectory path
+loadCertificatesFromDirectory :: FilePath -> IO [CurveCertificate]
+loadCertificatesFromDirectory filepath = do
+  files <- listDirectory filepath
   catMaybes <$> forM files (\file -> hush <$> loadCertificateFromFile file)
 

quik-connector.cabal

@@ -75,7 +75,7 @@ library
 executable quik-connector-exe
   hs-source-dirs:      app
   main-is:             Main.hs
-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall -Werror
   build-depends:       base
                      , quik-connector
                      , Win32
@@ -100,6 +100,7 @@ executable quik-connector-exe
                      , directory
                      , errors
   default-language:    Haskell2010
+  other-modules:       Config
 -- extra-libraries:     "user32"
 
 test-suite quik-connector-test

src/Broker/PaperBroker.hs

@@ -96,21 +96,28 @@ executePendingOrders tick state = do
   atomicModifyIORef' state (\s -> (s { pendingOrders = L.filter (\order -> orderId order `L.notElem` executedIds) (pendingOrders s)}, ()))
   where
     execute order =
+      if security tick == orderSecurity order
+        then
           case orderPrice order of
             Market -> do
+              debugM "PaperBroker" "Executing: pending market order"
               executeAtTick state order tick
               return $ Just $ orderId order
-        Limit price -> executeLimitAt price order
+            Limit price -> do
+              executeLimitAt price order
             _ -> return Nothing
+        else return Nothing
 
     executeLimitAt price order = case orderOperation order of
       Buy -> if (datatype tick == Price && price > value tick && value tick > 0) || (datatype tick == BestOffer && price > value tick && value tick > 0)
         then do
+          debugM "PaperBroker" $ "[1]Executing: pending limit order: " ++ show (security tick) ++ "/" ++ show (orderSecurity order)
           executeAtTick state order $ tick { value = price }
           return $ Just $ orderId order
         else return Nothing
       Sell -> if (datatype tick == Price && price < value tick && value tick > 0) || (datatype tick == BestBid && price < value tick && value tick > 0)
         then do
+          debugM "PaperBroker" $ "[2]Executing: pending limit order: " ++ show (security tick) ++ "/" ++ show (orderSecurity order)
           executeAtTick state order $ tick { value = price }
           return $ Just $ orderId order
         else return Nothing
@@ -173,6 +180,7 @@ pbSubmitOrder state order = do
       then rejectOrder state order
       else do
         tm <- tickMap <$> readIORef state
+        debugM "PaperBroker" $ "Limit order submitted, looking up: " ++ show key
         case M.lookup key tm of
           Nothing -> do
             let newOrder = order { orderState = Submitted }
@@ -180,7 +188,9 @@ pbSubmitOrder state order = do
             maybeCall notificationCallback state $ OrderNotification (orderId order) Submitted
           Just tick ->
             if ((orderOperation order == Buy) && (value tick < price)) || ((orderOperation order == Sell) && (value tick > price))
-              then executeAtTick state order tick
+              then do
+                maybeCall notificationCallback state $ OrderNotification (orderId order) Submitted
+                executeAtTick state order tick
               else do
                 let newOrder = order { orderState = Submitted }
                 atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s , pendingOrders = newOrder : pendingOrders s}, ()))

src/Broker/QuikBroker.hs

@@ -28,8 +28,6 @@ import Control.Monad.Trans.Except
 import Control.Monad.IO.Class
 import System.Log.Logger
 
-import Network.Telegram
-
 import Safe
 
 type QuikOrderId = Integer
@@ -51,8 +49,8 @@ maybeCall proj state arg = do
     Just callback -> callback arg
     Nothing -> return ()
 
-mkQuikBroker :: Manager -> FilePath -> FilePath -> [T.Text] -> ExceptT T.Text IO BrokerInterface
-mkQuikBroker man dllPath quikPath accs = do
+mkQuikBroker :: FilePath -> FilePath -> [T.Text] -> ExceptT T.Text IO BrokerInterface
+mkQuikBroker dllPath quikPath accs = do
   q <- mkQuik dllPath quikPath
 
   msgChan <- liftIO $ newBoundedChan 100