TXMLConnector: fix reconnection (again)

src/TXMLConnector.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns               #-}
 {-# LANGUAGE DuplicateRecordFields      #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -196,6 +197,7 @@ data BrokerState =
   , bsPendingOrders         :: TVar (D.Deque Order)
   }
 
+
 data Env =
   Env
   {
@@ -382,7 +384,7 @@ workThread = do
               resp <- asks responseVar >>= liftIO . atomically . tryReadTMVar
               log Debug "TXMLConnector.WorkThread" $ "Incoming candles: " <> (T.pack . show . length) (cCandles respCandle)
               case resp of
-                Just tmvar -> if cStatus respCandle == StatusPending
+                Just !tmvar -> if cStatus respCandle == StatusPending
                   then do
                     cur <- asks currentCandles
                     liftIO $ atomically . modifyTVar' cur $ (\c -> cCandles respCandle <> c)
@@ -596,12 +598,41 @@ workThread = do
           log Debug "TXMLConnector.WorkThread" $
             "Incoming client data: " <> (T.pack . show) (cClientId clientData) <> "#" <> (T.pack . show) (cUnion clientData)
         _ -> pure ()
+
     handleUnconnected :: App ()
     handleUnconnected = do
       cfg <- asks config
       log Debug "TXMLConnector.WorkThread" "Sending connect command"
-      v <- liftIO . sendCommand .
+      v <- liftIO . sendCommand . toXml $ cmdConnect cfg
-        toXml $ CommandConnect
+      case v of
+        Left _ -> do
+          log Warning "TXMLConnector.WorkThread" "Unable to connect"
+          liftIO $ do
+            void $ sendCommand $ toXml CommandDisconnect
+            threadDelay reconnectionDelay
+          queue <- asks transaqQueue
+          void $ liftIO $ atomically $ flushTBQueue queue
+        Right _ -> do
+          log Info "TXMLConnector.WorkThread" "Connected"
+          conn <- asks serverConnected
+          liftIO . atomically $ writeTVar conn StageGetInfo
+
+    makeSubscriptions config = liftIO . sendCommand . toXml $ cmdSubscription config
+
+    subscriptionToSecurityId (SubscriptionConfig brd code) = SecurityId brd code
+    insertToTickMap tickMap tick = insertTick tickMap tick
+
+    reconnectionDelay = 1000 * 1000 * 10
+
+    cmdSubscription config =
+      CommandSubscribe
+        {
+          alltrades = fmap subscriptionToSecurityId (allTradesSubscriptions config),
+          quotations = fmap subscriptionToSecurityId (quotationsSubscriptions config),
+          quotes = fmap subscriptionToSecurityId (quotesSubscriptions config)
+        }
+
+    cmdConnect cfg = CommandConnect
           {
             login = transaqLogin cfg,
             password = transaqPassword cfg,
@@ -619,27 +650,6 @@ workThread = do
             pushULimits = Nothing,
             pushPosEquity = Nothing
           }
-      case v of
-        Left _ -> do
-          log Warning "TXMLConnector.WorkThread" "Unable to connect"
-          void $ liftIO $ sendCommand $ toXml $ CommandDisconnect
-          liftIO $ threadDelay (1000 * 1000 * 10)
-          queue <- asks transaqQueue
-          void $ liftIO $ atomically $ flushTBQueue queue
-        Right _ -> do
-          log Info "TXMLConnector.WorkThread" "Connected"
-          conn <- asks serverConnected
-          liftIO . atomically $ writeTVar conn StageGetInfo
-    makeSubscriptions config =
-      liftIO . sendCommand . toXml $
-        CommandSubscribe
-        {
-          alltrades = fmap subscriptionToSecurityId (allTradesSubscriptions config),
-          quotations = fmap subscriptionToSecurityId (quotationsSubscriptions config),
-          quotes = fmap subscriptionToSecurityId (quotesSubscriptions config)
-        }
-    subscriptionToSecurityId (SubscriptionConfig brd code) = SecurityId brd code
-    insertToTickMap tickMap tick = insertTick tickMap tick
 
 allTradeToTick :: AllTradesTrade -> Tick
 allTradeToTick att =