txmlconnector: request timeout

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
@@ -155,6 +159,7 @@ data Env =
   , tisHandle        :: TickerInfoServerHandle
   , requestVar       :: TMVar Request
   , responseVar      :: TMVar (TMVar Response)
+  , requestTimestamp :: TVar UTCTime
   , currentCandles   :: TVar [Candle]
   , tickMap          :: TVar (M.Map TickKey Tick)
   , transaqQueue     :: TBQueue TransaqResponse
@@ -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