diff --git a/src/TXML.hs b/src/TXML.hs index 71ca7e4..4d43c82 100644 --- a/src/TXML.hs +++ b/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 diff --git a/src/TXMLConnector.hs b/src/TXMLConnector.hs index 6e2510f..542d901 100644 --- a/src/TXMLConnector.hs +++ b/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 diff --git a/src/Transaq.hs b/src/Transaq.hs index be537b4..7439c91 100644 --- a/src/Transaq.hs +++ b/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