diff --git a/src/TXMLConnector.hs b/src/TXMLConnector.hs index 2843751..7c89d41 100644 --- a/src/TXMLConnector.hs +++ b/src/TXMLConnector.hs @@ -35,7 +35,7 @@ import Control.Concurrent.STM (TVar, atomically, modifyTVar', tryReadTMVar, writeTVar) import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueue, readTBQueue, writeTBQueue) -import Control.Monad (forever, void) +import Control.Monad (forever, void, when) import Data.Maybe (mapMaybe) import qualified Data.Text as T import Text.XML.Light.Input (parseXML) @@ -85,7 +85,8 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Reader (ReaderT (runReaderT)) import Control.Monad.Reader.Class (MonadReader, asks) import qualified Data.Map.Strict as M -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock (UTCTime, diffUTCTime, + getCurrentTime) import Prelude hiding (log) import TickerInfoServer (TickerInfo (..), TickerInfoServerHandle, @@ -118,7 +119,9 @@ newtype Request = Request HistoryRequest deriving (Show, Eq, Ord) -data Response = ResponseHistory HistoryResponse +data Response = + ResponseHistory HistoryResponse + | ResponseTimeout data HistoryResponse = HistoryResponse @@ -135,6 +138,7 @@ data TXMLConnectorHandle = , notificationQueue :: TBQueue TransaqResponse , hRequestVar :: TMVar Request , hResponseVar :: TMVar (TMVar Response) + , hRequestTimestamp :: TVar UTCTime } data ConnectionStage = StageConnection | StageGetInfo | StageConnected @@ -151,17 +155,18 @@ data TickKey = TickKey TickerId DataType data Env = Env { - qssChannel :: BoundedChan QuoteSourceServerData - , tisHandle :: TickerInfoServerHandle - , requestVar :: TMVar Request - , responseVar :: TMVar (TMVar Response) - , currentCandles :: TVar [Candle] - , tickMap :: TVar (M.Map TickKey Tick) - , transaqQueue :: TBQueue TransaqResponse - , logger :: LogAction IO Message - , config :: TransaqConnectorConfig - , serverConnected :: TVar ConnectionStage - , candleKindMap :: TVar (M.Map Int Int) + qssChannel :: BoundedChan QuoteSourceServerData + , tisHandle :: TickerInfoServerHandle + , requestVar :: TMVar Request + , responseVar :: TMVar (TMVar Response) + , requestTimestamp :: TVar UTCTime + , currentCandles :: TVar [Candle] + , tickMap :: TVar (M.Map TickKey Tick) + , transaqQueue :: TBQueue TransaqResponse + , logger :: LogAction IO Message + , config :: TransaqConnectorConfig + , serverConnected :: TVar ConnectionStage + , candleKindMap :: TVar (M.Map Int Int) } newtype App a = App { unApp :: ReaderT Env IO a } @@ -186,6 +191,7 @@ start logger config qssChannel tisH = do currentCandles <- newTVarIO [] serverConnected <- liftIO $ newTVarIO StageConnection candleKindMap <- newTVarIO M.empty + requestTimestamp <- getCurrentTime >>= newTVarIO let env = Env { @@ -193,6 +199,7 @@ start logger config qssChannel tisH = do , tisHandle = tisH , requestVar = requestVar , responseVar = responseVar + , requestTimestamp = requestTimestamp , currentCandles = currentCandles , tickMap = tickTable , transaqQueue = notificationQueue @@ -310,6 +317,21 @@ workThread = do } _ -> log Warning "TXMLConnector.WorkThread" $ "Unable to parse security ID: " <> hrTickerId request _ -> log Warning "TXMLConnector.WorkThread" $ "Invalid candlekind requested" <> (T.pack . show . unBarTimeframe . hrTimeframe $ request) + checkRequestTimeout + + requestTimeout = 10 + + checkRequestTimeout = do + now <- liftIO getCurrentTime + tsVar <- asks requestTimestamp + ts <- liftIO $ readTVarIO tsVar + when (now `diffUTCTime` ts >= requestTimeout) $ do + resp <- asks responseVar >>= liftIO . atomically . tryReadTMVar + case resp of + Just tmvar -> do + log Warning "TXMLConnector.WorkThread" "Request timeout" + liftIO . atomically . putTMVar tmvar $ ResponseTimeout + _ -> pure () handleGetInfo :: App () handleGetInfo = do @@ -474,8 +496,10 @@ makeTickerId sec = board sec <> "#" <> seccode sec makeRequest :: TXMLConnectorHandle -> Request -> IO Response makeRequest h request = do + now <- getCurrentTime resp <- atomically $ do resp <- newEmptyTMVar + writeTVar (hRequestTimestamp h) now putTMVar (hResponseVar h) resp putTMVar (hRequestVar h) request pure resp