@@ -25,7 +25,7 @@ import Data.Int
2525import Data.IORef
2626import qualified Data.IntMap as IntMap
2727import qualified Data.ByteString.Char8 as BS
28−import Data.Time.Clock (getCurrentTime, diffUTCTime) -- Not in 6.10
28+import Data.Time.Clock (getCurrentTime, diffUTCTime, UTCTime) -- Not in 6.10
2929
3030-- For some STRANGE reason this is not working with Data.Binary [2012.02.20]:
3131#define CEREAL
@@ -100,7 +100,7 @@ mkTransport = do
100100 { newConnectionWith = \ _ -> do
101101 -- Here we protect from blocking other threads by running on a separate (OS) thread:
102102 -- Opening the file on the reader side should always succeed:
103− mv <- onOSThread$ tryUntilNoIOErr $
103+ mv <- onOSThread$ tryUntilNoIOErr "open pipe for read" $
104104-- spinTillThere filename
105105 PIO.openFd filename PIO.ReadOnly Nothing fileFlags
106106
@@ -120,7 +120,7 @@ mkTransport = do
120120 mkSourceEnd :: String -> IO SourceEnd
121121 mkSourceEnd filename = do
122122 -- Initiate but do not block on file opening:
123− mv <- onOSThread$ tryUntilNoIOErr $
123+ mv <- onOSThread$ tryUntilNoIOErr "open pipe for write" $
124124 -- The reader must connect first, the writer here spins with backoff.
125125 PIO.openFd filename PIO.WriteOnly Nothing fileFlags
126126
@@ -177,7 +177,7 @@ mkTransport = do
177177 let spinread :: Int -> IO BS.ByteString
178178 spinread desired = do
179179
180− bs <- tryUntilNoIOErr$
180+ bs <- tryUntilNoIOErr "read pipe file descriptor"$
181181 readit fd (fromIntegral desired)
182182
183183 case BS.length bs of
@@ -207,13 +207,14 @@ mkTransport = do
207207 PIO.closeFd fd
208208 }
209209
210+-- | Wait untila file is present, with backoff.
210211spinTillThere :: String -> IO ()
211212spinTillThere filename = mkBackoff >>= loop
212213 where
213214 loop bkoff = do b <- doesFileExist filename
214215 unless b $ do bkoff; loop bkoff
215216
216−-- Wait successively longer between attempts.
217+-- | Create a backoff action that waits successively longer between attempts.
217218mkBackoff :: IO (IO ())
218219mkBackoff =
219220 do tref <- newIORef 1
@@ -223,31 +224,37 @@ mkBackoff =
223224 where
224225 maxwait = 50 * 1000
225226
226−tryUntilNoIOErr :: IO a -> IO a
227−tryUntilNoIOErr action =
227+-- | Try an IO action repeatedly (with backoff) until it succeeds without exception.
228+tryUntilNoIOErr :: String -> IO a -> IO a
229+tryUntilNoIOErr msg action =
228230 do startTime <- getCurrentTime
229231 bkoff <- mkBackoff
230− loop startTime bkoff
231−
232+ loop startTime startTime bkoff
232233 where
233− loop start bkoff =
234+ loop start lastWarned bkoff =
234235 handle (\ (e :: IOException) ->
235− do maybeWarn start
236+ do lw <- maybeWarn start lastWarned
236237 bkoff
237238-- BSS.hPutStr stderr$ BSS.pack$ " got IO err: " ++ show e
238239 -- case ioeGetHandle e of
239240 -- Nothing -> BSS.hPutStrLn stderr$ BSS.pack$ " no hndl io err."
240241 -- Just x -> BSS.hPutStrLn stderr$ BSS.pack$ " HNDL on io err!" ++ show x
241− loop start bkoff) $
242+ loop start lw bkoff) $
242243 action
243244 -- After how many milleseconds should we start warning?
244245 warn_lvl = 3000
245− maybeWarn start = do
246+ maybeWarn :: UTCTime -> UTCTime -> IO UTCTime
247+ maybeWarn start lastWarned = do
246248 now <- getCurrentTime
247− let seconds :: Double = fromRational $ toRational $ diffUTCTime now start
248− when (seconds * 1000 >= warn_lvl) $
249− BS.hPutStrLn stderr$ BS.pack$ "WARNING: have been trying an IO action for "++show seconds++ " seconds without success"
250−
249+ let seconds :: Double = fromRational $ toRational $ diffUTCTime now start
250+ sinceWarned :: Double = fromRational $ toRational $ diffUTCTime now lastWarned
251+ if (seconds * 1000 >= warn_lvl &&
252+ sinceWarned >= 1.0 ) then do
253+ BS.hPutStrLn stderr$ BS.pack$ "WARNING: have been trying an IO action ("++msg++
254+ ") for "++show seconds++ " seconds without success"
255+ return now
256+ else
257+ return lastWarned
251258
252259-- Execute an action on its own OS thread. Return an MVar to synchronize on.
253260onOSThread :: IO a -> IO (MVar a)