@@ -25,6 +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
2829
2930-- For some STRANGE reason this is not working with Data.Binary [2012.02.20]:
3031#define CEREAL
@@ -212,6 +213,7 @@ spinTillThere filename = mkBackoff >>= loop
212213 loop bkoff = do b <- doesFileExist filename
213214 unless b $ do bkoff; loop bkoff
214215
216+-- Wait successively longer between attempts.
215217mkBackoff :: IO (IO ())
216218mkBackoff =
217219 do tref <- newIORef 1
@@ -222,17 +224,30 @@ mkBackoff =
222224 maxwait = 50 * 1000
223225
224226tryUntilNoIOErr :: IO a -> IO a
225−tryUntilNoIOErr action = mkBackoff >>= loop
227+tryUntilNoIOErr action =
228+ do startTime <- getCurrentTime
229+ bkoff <- mkBackoff
230+ loop startTime bkoff
231+
226232 where
227− loop bkoff =
233+ loop start bkoff =
228234 handle (\ (e :: IOException) ->
229− do bkoff
235+ do maybeWarn start
236+ bkoff
230237-- BSS.hPutStr stderr$ BSS.pack$ " got IO err: " ++ show e
231238 -- case ioeGetHandle e of
232239 -- Nothing -> BSS.hPutStrLn stderr$ BSS.pack$ " no hndl io err."
233240 -- Just x -> BSS.hPutStrLn stderr$ BSS.pack$ " HNDL on io err!" ++ show x
234− loop bkoff) $
241+ loop start bkoff) $
235242 action
243+ -- After how many milleseconds should we start warning?
244+ warn_lvl = 3000
245+ maybeWarn start = do
246+ 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+
236251
237252-- Execute an action on its own OS thread. Return an MVar to synchronize on.
238253onOSThread :: IO a -> IO (MVar a)