BrokerServer

src/TXML.hs

@@ -81,7 +81,6 @@ uninitialize = c_UnInitialize >>= rawStringToResult
 
 sendCommand :: T.Text -> IO (Either T.Text ())
 sendCommand cmdData = do
-  putStrLn $ T.unpack cmdData
   BS.useAsCString (encodeUtf8 cmdData) $ \fpcstr ->
     c_SendCommand fpcstr >>= rawStringToResult
 

src/TXMLConnector.hs

@@ -47,6 +47,7 @@ import           Text.XML.Light.Types           (Content (Elem),
                                                  QName (qName))
 import           Transaq                        (AllTradesTrade (..),
                                                  Candle (..), ClientData (..),
+                                                 CommandChangePass (..),
                                                  CommandConnect (..),
                                                  CommandDisconnect (CommandDisconnect),
                                                  CommandGetHistoryData (CommandGetHistoryData),
@@ -94,8 +95,10 @@ import           ATrade.Types                   (Bar (..),
                                                  fromDouble, toDouble)
 import qualified ATrade.Types                   as AT
 import           Colog.Monad                    (WithLog)
+import           Control.Applicative            ((<|>))
 import           Control.Concurrent.BoundedChan (BoundedChan, writeChan)
 import           Control.Concurrent.STM.TMVar   (TMVar)
+import           Control.Error                  (headMay)
 import           Control.Monad                  (forM_)
 import           Control.Monad.IO.Class         (MonadIO (liftIO))
 import           Control.Monad.Reader           (ReaderT (runReaderT))
@@ -311,6 +314,9 @@ workThread = do
       "quotations"    -> TransaqResponseQuotations <$> fromXml el
       "alltrades"     -> TransaqResponseAllTrades <$> fromXml el
       "quotes"        -> TransaqResponseQuotes <$> fromXml el
+      "orders"        -> TransaqResponseOrders <$> fromXml el
+      "trades"        -> TransaqResponseTrades <$> fromXml el
+      "result"        -> TransaqResponseResult <$> fromXml el
       _               -> Nothing
     writeToQueue queue resp = atomically $ writeTBQueue queue resp
     handleConnected :: App ()
@@ -354,15 +360,6 @@ workThread = do
                 _ -> log Warning "TXMLConnector.WorkThread" "Incoming candles without response var"
             TransaqResponseOrders (ResponseOrders orders) -> forM_ orders handleOrder
             TransaqResponseTrades (ResponseTrades trades) -> forM_ trades handleTrade
-            TransaqResponseResult (ResponseSuccess (Just transactionId)) -> do
-              brState <- asks brokerState
-              liftIO $ atomically $ do
-                deque <- readTVar (bsPendingOrders brState)
-                case D.uncons deque of
-                  Just (order, deque') -> do
-                    writeTVar (bsPendingOrders brState) deque'
-                    modifyTVar' (bsOrderTransactionIdMap brState) (BM.insert (orderId order) (TransactionId transactionId))
-                  Nothing -> pure ()
             _ -> pure ()
         MainQueueRequest (RequestHistory request) -> do
           cur <- asks currentCandles
@@ -386,12 +383,21 @@ workThread = do
             Just cmd -> do
               v <- liftIO . sendCommand . toXml $ cmd
               case v of
-                Left err -> log Warning "TXMLConnector.WorkThread" $ "Unable to send request: [" <> err <> "]"
+                Left result -> do
+                  case headMay (parseXML result) >>= parseContent of
+                    Just (TransaqResponseResult (ResponseSuccess (Just transactionId))) -> do
+                      brState <- asks brokerState
+                      respVar <- asks responseVar
+                      liftIO $ atomically $ do
+                        modifyTVar' (bsOrderMap brState) (M.insert (orderId order) order)
+                        modifyTVar' (bsOrderTransactionIdMap brState) (BM.insert (orderId order) (TransactionId transactionId))
+                        resp <- readTMVar respVar
+                        putTMVar resp ResponseOrderSubmitted
+                      log Debug "TXMLConnector.WorkThread" $ "Inserting orderid: " <>
+                        (T.pack . show) (orderId order) <> " <-> " <> (T.pack . show) transactionId
+                    _ -> log Warning "TXMLConnector.WorkThread" "Unable to parse result"
                 Right _ -> do
-                  brState <- asks brokerState
-                  liftIO $ atomically $ do
-                    modifyTVar' (bsPendingOrders brState) (order `D.snoc`)
-                    modifyTVar' (bsOrderMap brState) (M.insert (orderId order) order)
+                  log Warning "TXMLConnector.WorkThread" "Expected result, got nothing"
             _ -> pure ()
         _ -> pure ()
 
@@ -407,10 +413,13 @@ workThread = do
       case maybeCb of
         Just cb -> case BM.lookupR (ExchangeOrderId (tOrderNo transaqTrade)) trIdMap of
           Just oid -> case M.lookup oid orderMap of
-            Just order -> liftIO $ cb (BackendTradeNotification (fromTransaqTrade transaqTrade order))
-            _ -> pure ()
-          _ -> pure ()
-        Nothing -> pure ()
+            Just order -> do
+              let notif = BackendTradeNotification (fromTransaqTrade transaqTrade order)
+              log Debug "TXMLConnector.WorkThread" $ "Sending trade notification: " <> (T.pack . show) notif
+              liftIO $ cb notif
+            _ -> log Warning "TXMLConnector.WorkThread" $ "Unable to find order for trade: " <> (T.pack . show) transaqTrade
+          _ -> log Warning "TXMLConnector.WorkThread" $ "Unable to find order in ordermap: " <> (T.pack . show) transaqTrade
+        Nothing -> log Warning "TXMLConnector.WorkThread" $ "No callback for trade notification!"
 
     fromTransaqTrade transaqTrade order =
       Trade
@@ -436,10 +445,18 @@ workThread = do
       trIdMap <- liftIO $ readTVarIO (bsOrderTransactionIdMap brState)
       maybeCb <- liftIO $ readTVarIO (bsNotificationCallback brState)
       case maybeCb of
-        Just cb -> case BM.lookupR (TransactionId (fromIntegral $ oTransactionId orderUpdate)) trIdMap of
-          Just oid -> liftIO $ cb (BackendOrderNotification oid (orderStateFromTransaq orderUpdate))
-          _ -> pure ()
-        Nothing -> pure ()
+        Just cb -> case BM.lookupR (ExchangeOrderId (oOrderNo orderUpdate)) trIdMap <|>
+          BM.lookupR (TransactionId (fromIntegral $ oTransactionId orderUpdate)) trIdMap of
+          Just oid -> do
+            let notif = BackendOrderNotification oid (orderStateFromTransaq orderUpdate)
+            log Debug "TXMLConnector.WorkThread" $ "Sending order notification: " <> (T.pack . show) notif
+            liftIO $ atomically $ do
+              m <- readTVar (bsOrderTransactionIdMap brState)
+              when (BM.notMemberR (ExchangeOrderId (oOrderNo orderUpdate)) m) $ do
+                modifyTVar' (bsOrderTransactionIdMap brState) (BM.insert oid (ExchangeOrderId $ oOrderNo orderUpdate))
+            liftIO $ cb notif
+          _ -> log Warning "TXMLConnector.WorkThread" "Unable to find order for order notification"
+        Nothing -> log Warning "TXMLConnector.WorkThread" "No callback for order notification"
 
     orderStateFromTransaq orderUpdate =
       case oStatus orderUpdate of
@@ -484,6 +501,8 @@ workThread = do
               liftIO . atomically $ writeTVar conn StageConnection
             Transaq.Connected -> do
               log Info "TXMLConnector.WorkThread" "Server connected"
+              void $ liftIO . sendCommand $ toXml $
+                CommandChangePass (transaqPassword cfg) "goobaka12"
               liftIO . atomically $ writeTVar conn StageConnected
               v <- makeSubscriptions cfg
               case v of

src/Transaq.hs

@@ -15,6 +15,7 @@ module Transaq
     CommandCancelOrder(..),
     CommandGetSecuritiesInfo(..),
     CommandGetHistoryData(..),
+    CommandChangePass(..),
     ResponseResult(..),
     ResponseCandles(..),
     ResponseServerStatus(..),
@@ -310,6 +311,20 @@ instance TransaqCommand CommandGetSecuritiesInfo where
     T.pack . showElement $ unode "command" ([strAttr "id" "get_securities_info"],
       fmap (unode "security") securities)
 
+data CommandChangePass =
+  CommandChangePass
+  {
+    cOldPass :: T.Text
+  , cNewPass :: T.Text
+  } deriving (Show, Eq)
+
+instance TransaqCommand CommandChangePass where
+  toXml CommandChangePass{..} =
+    T.pack . showElement $ unode "command"
+      [strAttr "id" "change_pass",
+       strAttr "oldpass" $ T.unpack cOldPass,
+       strAttr "newpass" $ T.unpack cNewPass]
+
 data ResponseResult =
     ResponseSuccess (Maybe Int64)
   | ResponseFailure T.Text