[英]How would I pipe with a timeout that resets with each incoming?
withTimeout
函数假设管道ConsoleEvent
,如果没有收到任何内容,则每隔s :: Int
秒发送一次CeTimeout
。 相反,它无法在适当的时间发送CeTimeout
事件。 如果大于s
秒且原始事件丢失,则会将一个CeTimeout
事件替换为其他事件。 此外,而不是一个CeTimeout
事件,应该是n*s
CeTimeout
与事件n
每个计数s
已经过去了2期。 错误在哪里,纠正是什么? 谢谢!
withTimeout :: (MonadIO t) => Int -> Pipe ConsoleEvent ConsoleEvent t ()
withTimeout ((* 1000000) -> s) = join . liftIO $ work
where
work :: (MonadIO t) => IO (Pipe ConsoleEvent ConsoleEvent t ())
work =
do
(oSent, iKept) <- spawn $ bounded 1
(oKept, iSent) <- spawn $ unbounded
(oTimeout, iTimeout) <- spawn $ bounded 1
tid <- launchTimeout oTimeout >>= newMVar
forkIO $ do
runEffect . forever $ fromInput iKept >-> factorTimeout tid oTimeout >-> toOutput oKept
forkIO $ do
runEffect . forever $ fromInput iTimeout >-> toOutput oKept
return $ do
await >>= (liftIO . guardedSend oSent)
(liftIO . guardedRecv $ iSent) >>= yield
guardedSend :: Output ConsoleEvent -> ConsoleEvent -> IO ()
guardedSend o ce =
(atomically $ send o ce) >>= \case
True -> return ()
otherwise -> die $ "withTimeout can not send"
guardedRecv :: Input ConsoleEvent -> IO ConsoleEvent
guardedRecv i =
(atomically $ recv i) >>= \case
Just a -> return a
otherwise -> die $ "withTimeout can not recv"
launchTimeout :: Output ConsoleEvent -> IO ThreadId
launchTimeout o =
forkIO . forever $ do
threadDelay $ s
(atomically $ send o CeTimeout) >>= \case
True -> return ()
otherwise -> die "withTimeout can not send timeout"
relaunchTimeout :: Output ConsoleEvent -> ThreadId -> IO ThreadId
relaunchTimeout o oldTid =
do
tid <- launchTimeout o
killThread oldTid
return tid
factorTimeout :: MVar ThreadId -> Output ConsoleEvent -> Pipe ConsoleEvent ConsoleEvent IO ()
factorTimeout v o =
do
ce <- await
liftIO . modifyMVar_ v $ relaunchTimeout o
yield ce
这是一个完全可执行的脚本 。
这似乎是一个Pipe
将只允许一个yield
每await
。 这意味着CeTimeout
不能随意向管道发送,因为没有任何东西进入管道导致流动。 我将不得不通过消息来源证实这一点; 与此同时,此函数已重构为返回Pipe
和Producer
而不仅仅是Pipe
。 该Producer
然后可以在调用函数中加入回来。 最初的计划是只返回一个Pipe
这样调用函数就不需要做任何额外的工作来使超时工作。 那本来是一个更独立的解决方案。 这个替代方案很好,因为它更明确。 对于不熟悉管道的人来说,超时看起来并不像是显得空洞。
withTimeout :: (MonadIO t) => Int -> IO (Pipe ConsoleEvent ConsoleEvent t (), Producer ConsoleEvent t ())
withTimeout ((* 1000000) -> s) =
do
(oTimeout, iTimeout) <- spawn $ bounded 1
vTid <- launchTimeout oTimeout >>= newMVar
return (factorTimeout vTid oTimeout, fromInput iTimeout)
where
launchTimeout :: Output ConsoleEvent -> IO ThreadId
launchTimeout o =
forkIO . forever $ do
threadDelay $ s
(atomically $ send o CeTimeout) >>= \case
True -> return ()
otherwise -> die "withTimeout can not send timeout"
relaunchTimeout :: Output ConsoleEvent -> ThreadId -> IO ThreadId
relaunchTimeout o oldTid =
do
tid <- launchTimeout o
killThread oldTid
return tid
factorTimeout :: (MonadIO t) => MVar ThreadId -> Output ConsoleEvent -> Pipe ConsoleEvent ConsoleEvent t ()
factorTimeout v o =
do
ce <- await
liftIO . modifyMVar_ v $ relaunchTimeout o
yield ce
main :: IO ()
main =
do
hSetBuffering stdin NoBuffering
hSetEcho stdin False
exitSemaphore <- newEmptyMVar
(o1, i1) <- spawn $ bounded 1
(o2, i2) <- spawn $ bounded 1
(timeoutTrap, timeoutRender) <- withTimeout 2
runEffect $ yield CeBegan >-> toOutput o1
forkIO $ do
runEffect . forever $ chars >-> toOutput o1
putMVar exitSemaphore ()
-- other inputs would be piped to o1 here
forkIO $ do
runEffect . forever $ fromInput i1 >-> timeoutTrap >-> toOutput o2
putMVar exitSemaphore ()
forkIO $ do
runEffect . forever $ timeoutRender >-> toOutput o2
putMVar exitSemaphore ()
forkIO $ do
-- logic would be done before dumpPipe
runEffect . forever $ fromInput i2 >-> dumpPipe >-> (await >> return ())
putMVar exitSemaphore ()
takeMVar exitSemaphore
这是一个完全可执行的脚本 。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.