Merge pull request #163 from serokell/diogo/#162-interrupt-io

[#162] Do not cancel the progress bar thread

CHANGES.md

@@ -8,9 +8,10 @@ Unreleased
 ==========
 * [#145](https://github.com/serokell/xrefcheck/pull/145)
   + Add check that there is no unknown fields in config.
-
 * [#158](https://github.com/serokell/xrefcheck/pull/158)
   + Fixed bug when we reported footnotes as broken links
+* [#163](https://github.com/serokell/xrefcheck/pull/163)
+  + Fixed an issue where the progress bar thread might be unexpectedly cancelled and jumble up the output.
 
 0.2.1
 ==========

src/Xrefcheck/Progress.hs

@@ -31,7 +31,7 @@ import Universum
 
 import Data.Ratio ((%))
 import System.Console.Pretty (Color (..), Style (..), color, style)
-import Time (Second, Time, ms, sec, threadDelay, unTime, (-:-))
+import Time (Second, Time, sec, unTime, (-:-))
 
 -----------------------------------------------------------
 -- Task timestamp
@@ -225,8 +225,6 @@ allowRewrite enabled = bracket prepare erase
     erase (Rewrite RewriteCtx{..}) = liftIO $ do
       maxPrintedSize <- readIORef rMaxPrintedSize
       hPutStr stderr $ '\r' : replicate maxPrintedSize ' ' ++ "\r"
-      -- prevent our output to interleave with further outputs
-      threadDelay (ms 100)
     erase RewriteDisabled = pass
 
 -- | Return caret and print the given text.

src/Xrefcheck/Verify.hs

@@ -33,8 +33,9 @@ module Xrefcheck.Verify
 
 import Universum
 
-import Control.Concurrent.Async (wait, withAsync)
+import Control.Concurrent.Async (async, wait, withAsync)
 import Control.Exception (throwIO)
+import Control.Monad.Catch (handleJust)
 import Control.Monad.Except (MonadError (..))
 import Data.ByteString qualified as BS
 import Data.List qualified as L
@@ -43,7 +44,7 @@ import Data.Text.Metrics (damerauLevenshteinNorm)
 import Data.Time (UTCTime, defaultTimeLocale, formatTime, readPTime, rfc822DateFormat)
 import Data.Time.Clock.POSIX (getPOSIXTime)
 import Data.Traversable (for)
-import Fmt (Buildable (..), blockListF', listF, maybeF, nameF, (+|), (|+), unlinesF, indentF)
+import Fmt (Buildable (..), blockListF', indentF, listF, maybeF, nameF, unlinesF, (+|), (|+))
 import GHC.Exts qualified as Exts
 import GHC.Read (Read (readPrec))
 import Network.FTP.Client
@@ -57,13 +58,12 @@ import Network.HTTP.Types.Header (hRetryAfter)
 import Network.HTTP.Types.Status (Status, statusCode, statusMessage)
 import System.Console.Pretty (Style (..), style)
 import System.Directory (doesDirectoryExist, doesFileExist)
-import System.FilePath (takeDirectory, (</>), normalise)
+import System.FilePath (normalise, takeDirectory, (</>))
 import Text.ParserCombinators.ReadPrec qualified as ReadPrec (lift)
 import Text.Regex.TDFA.Text (Regex, regexec)
-import Text.URI (Authority (..), URI (..), mkURIBs, ParseExceptionBs)
+import Text.URI (Authority (..), ParseExceptionBs, URI (..), mkURIBs)
 import Time (RatioNat, Second, Time (..), ms, sec, threadDelay, timeout, (+:+), (-:-))
 import URI.ByteString qualified as URIBS
-import Control.Monad.Catch (handleJust)
 
 import Data.Bits (toIntegralSized)
 import Xrefcheck.Config
@@ -265,12 +265,13 @@ verifyRepo
 
   progressRef <- newIORef $ initVerifyProgress (map snd toScan)
 
-  accumulated <- withAsync (printer progressRef) $ \_ ->
+  accumulated <- loopAsyncUntil (printer progressRef) do
     forConcurrentlyCaching toScan ifExternalThenCache $ \(file, ref) ->
       verifyReference config mode progressRef repoInfo' root file ref
   return $ fold accumulated
   where
-    printer progressRef = forever $ do
+    printer :: IORef VerifyProgress -> IO ()
+    printer progressRef = do
       posixTime <- getPOSIXTime <&> posixTimeToTimeSecond
       progress <- atomicModifyIORef' progressRef $ \VerifyProgress{..} ->
         let prog = VerifyProgress{ vrExternal =
@@ -279,8 +280,10 @@ verifyRepo
                                  }
         in (prog, prog)
       reprintAnalyseProgress rw mode posixTime progress
+      -- Slight pause so we're not refreshing the progress bar more often than needed.
       threadDelay (ms 100)
 
+    ifExternalThenCache :: (a, Reference) -> NeedsCaching Text
     ifExternalThenCache (_, Reference{..}) = case locationType rLink of
       ExternalLoc -> CacheUnderKey rLink
       _           -> NoCaching
@@ -621,3 +624,28 @@ checkExternalResource VerifyConfig{..} link
           pure ()
       where
         handler = if secure then withFTPS else withFTP
+
+----------------------------------------------------------------------------
+-- Helpers
+----------------------------------------------------------------------------
+
+-- | @loopAsyncUntil ma mb@ will continually run @ma@ until @mb@ throws an exception or returns.
+-- Once it does, it'll wait for @ma@ to finish running one last time and then return.
+--
+-- See #163 to read more on why it's important to let @ma@ finish cleanly.
+-- * https://github.com/serokell/xrefcheck/issues/162
+-- * https://github.com/serokell/xrefcheck/pull/163
+loopAsyncUntil :: forall a b. IO a -> IO b -> IO b
+loopAsyncUntil loopingAction action =
+  mask $ \restore -> do
+    shouldLoop <- newIORef True
+    loopingActionAsync <- async $ restore $ loopingAction' shouldLoop
+    restore action `finally` do
+      writeIORef shouldLoop False
+      wait loopingActionAsync
+  where
+    loopingAction' :: IORef Bool -> IO ()
+    loopingAction' shouldLoop = do
+      whenM (readIORef shouldLoop) do
+        void loopingAction
+        loopingAction' shouldLoop