{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
skipTimeout <- overridingTimeout <$> get
timeoutId <- getCurTimeoutId
- unless skipTimeout $ do
+ mtid <-
+ if skipTimeout
+ then pure Nothing
+ else Just <$> do
chan <- asks messageChan
timeout <- asks (messageTimeout . config)
- void $ liftIO $ forkIO $ do
+ liftIO $ forkIO $ do
threadDelay (timeout * 1000000)
writeChan chan (TimeoutMessage timeoutId)
x <- Session await
- unless skipTimeout (bumpTimeoutId timeoutId)
+ forM_ mtid $ \tid -> do
+ bumpTimeoutId timeoutId
+ liftIO $ killThread tid
modify $ \s -> s { lastReceivedMessage = Just x }
-- | Matches a request or a notification coming from the server.
message :: SServerMethod m -> Session (ServerMessage m)
-message m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case
+message m1 = named (T.pack $ "Request for: " <> show m1) $ satisfyMaybe $ \case
FromServerMess m2 msg -> do
HRefl <- mEqServer m1 m2
pure msg
-- | Matches a response coming from the server.
response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m)
-response m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case
+response m1 = named (T.pack $ "Response for: " <> show m1) $ satisfyMaybe $ \case
FromServerRsp m2 msg -> do
HRefl <- mEqClient m1 m2
pure msg