mirror of
https://github.com/serokell/xrefcheck.git
synced 2024-07-14 17:00:33 +03:00
Merge pull request #163 from serokell/diogo/#162-interrupt-io
[#162] Do not cancel the progress bar thread
This commit is contained in:
commit
54aa5415bf
@ -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
|
||||
==========
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user