[#162] Do not cancel the progress bar thread

Problem: The output of xrefcheck sometimes appears as a confusing mess,
see here for details and examples:
https://github.com/serokell/xrefcheck/issues/162

The culprit seems to be the `withAsync` used in `verifyRepo`. This
spawns a thread that prints and refreshes the progress bar, while the
main thread coordinates the verification of references.

The problem here is that, as the docs of `withAsync` explain, when the
main thread finishes/throws, the spawned thread will be cancelled with
`uninterruptibleCancel`.

If the thread is in the middle of updating the progress bar (printing
return carriages, writing over an existing line, printing control
characters to change the text color, etc), it'll be abruptly interrupted
and will not be given the chance to finish cleanly.

Solution: replace `withAsync` with `loopAsyncUntil`. This lets the
printer thread finish what it's currently doing.

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/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