{- SPDX-FileCopyrightText: 2018-2021 Serokell - - SPDX-License-Identifier: MPL-2.0 -} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -Wno-partial-type-signatures #-} module Xrefcheck.Verify ( -- * General verification VerifyResult (..) , verifyOk , verifyErrors , verifying , RetryAfter (..) , WithReferenceLoc (..) -- * Concurrent traversal with caching , NeedsCaching (..) , forConcurrentlyCaching -- * Cross-references validation , VerifyError (..) , verifyRepo , verifyReference , checkExternalResource -- * URI parsing , parseUri ) where import Universum 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 import Data.Map qualified as M import Data.Reflection (Given) 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', indentF, listF, maybeF, nameF, unlinesF, (+|), (|+)) import GHC.Exts qualified as Exts import GHC.Read (Read (readPrec)) import Network.FTP.Client (FTPException (..), FTPResponse (..), ResponseStatus (..), login, nlst, size, withFTP, withFTPS) import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), Response, responseHeaders, responseStatus) import Network.HTTP.Req (AllowsBody, CanHaveBody (NoBody), GET (..), HEAD (..), HttpBodyAllowed, HttpException (..), HttpMethod, NoReqBody (..), defaultHttpConfig, ignoreResponse, req, runReq, useURI) import Network.HTTP.Types.Header (hRetryAfter) import Network.HTTP.Types.Status (Status, statusCode, statusMessage) import System.FilePath (equalFilePath, joinPath, makeRelative, normalise, splitDirectories, takeDirectory, ()) import Text.ParserCombinators.ReadPrec qualified as ReadPrec (lift) import Text.Regex.TDFA.Text (Regex, regexec) import Text.URI (Authority (..), ParseExceptionBs, URI (..), mkURIBs) import Time (RatioNat, Second, Time (..), ms, sec, threadDelay, timeout, (+:+), (-:-)) import URI.ByteString qualified as URIBS import Data.Bits (toIntegralSized) import Xrefcheck.Config import Xrefcheck.Core import Xrefcheck.Orphans () import Xrefcheck.Progress import Xrefcheck.System import Xrefcheck.Util {-# ANN module ("HLint: ignore Use uncurry" :: Text) #-} {-# ANN module ("HLint: ignore Use 'runExceptT' from Universum" :: Text) #-} ----------------------------------------------------------- -- General verification ----------------------------------------------------------- newtype VerifyResult e = VerifyResult [e] deriving newtype (Show, Eq, Functor) deriving newtype instance Semigroup (VerifyResult e) deriving newtype instance Monoid (VerifyResult e) instance Buildable e => Buildable (VerifyResult e) where build vr = maybe "ok" listF (verifyErrors vr) verifyOk :: VerifyResult e -> Bool verifyOk (VerifyResult errors) = null errors verifyErrors :: VerifyResult e -> Maybe (NonEmpty e) verifyErrors (VerifyResult errors) = nonEmpty errors verifying :: Monad m => ExceptT e m () -> m (VerifyResult e) verifying (ExceptT action) = fmap toVerifyRes action toVerifyRes :: Either e () -> VerifyResult e toVerifyRes = VerifyResult . either one (\() -> []) ----------------------------------------------------------- -- Cross-references validation ----------------------------------------------------------- data WithReferenceLoc a = WithReferenceLoc { wrlFile :: FilePath , wrlReference :: Reference , wrlItem :: a } instance (Given ColorMode, Buildable a) => Buildable (WithReferenceLoc a) where build WithReferenceLoc{..} = "In file " +| styleIfNeeded Faint (styleIfNeeded Bold wrlFile) |+ "\nbad " +| wrlReference |+ "\n" +| wrlItem |+ "\n\n" data VerifyError = LocalFileDoesNotExist FilePath | LocalFileOutsideRepo FilePath | AnchorDoesNotExist Text [Anchor] | AmbiguousAnchorRef FilePath Text (NonEmpty Anchor) | ExternalResourceInvalidUri URIBS.URIParseError | ExternalResourceUriConversionError ParseExceptionBs | ExternalResourceInvalidUrl (Maybe Text) | ExternalResourceUnknownProtocol | ExternalHttpResourceUnavailable Status | ExternalHttpTooManyRequests (Maybe RetryAfter) | ExternalFtpResourceUnavailable FTPResponse | ExternalFtpException FTPException | FtpEntryDoesNotExist FilePath | ExternalResourceSomeError Text deriving stock (Show, Eq) instance Given ColorMode => Buildable VerifyError where build = \case LocalFileDoesNotExist file -> "⛀ File does not exist:\n " +| file |+ "\n" LocalFileOutsideRepo file -> "⛀ Link targets a local file outside repository:\n " +| file |+ "\n" AnchorDoesNotExist anchor similar -> "⛀ Anchor '" +| anchor |+ "' is not present" +| anchorHints similar AmbiguousAnchorRef file anchor fileAnchors -> "⛀ Ambiguous reference to anchor '" +| anchor |+ "'\n " +| "In file " +| file |+ "\n " +| "Similar anchors are:\n" +| blockListF' " -" build fileAnchors |+ "" +| " Use of such anchors is discouraged because referenced object\n\ \ can change silently whereas the document containing it evolves.\n" ExternalResourceInvalidUri err -> "⛂ Invalid URI (" +| err |+ ")\n" ExternalResourceUriConversionError err -> unlinesF [ "⛂ Invalid URI" , indentF 4 . build $ displayException err ] ExternalResourceInvalidUrl Nothing -> "⛂ Invalid URL\n" ExternalResourceInvalidUrl (Just message) -> "⛂ Invalid URL (" +| message |+ ")\n" ExternalResourceUnknownProtocol -> "⛂ Bad url (expected 'http','https', 'ftp' or 'ftps')\n" ExternalHttpResourceUnavailable status -> "⛂ Resource unavailable (" +| statusCode status |+ " " +| decodeUtf8 @Text (statusMessage status) |+ ")\n" ExternalHttpTooManyRequests retryAfter -> "⛂ Resource unavailable (429 Too Many Requests; retry after " +| maybeF retryAfter |+ ")\n" ExternalFtpResourceUnavailable response -> "⛂ Resource unavailable:\n" +| response |+ "\n" ExternalFtpException err -> "⛂ FTP exception (" +| err |+ ")\n" FtpEntryDoesNotExist entry -> "⛂ File or directory does not exist:\n" +| entry |+ "\n" ExternalResourceSomeError err -> "⛂ " +| build err |+ "\n\n" where anchorHints = \case [] -> "\n" [h] -> ",\n did you mean " +| h |+ "?\n" hs -> ", did you mean:\n" +| blockListF' " -" build hs data RetryAfter = Date UTCTime | Seconds (Time Second) deriving stock (Show, Eq) instance Read RetryAfter where readPrec = asum [ ReadPrec.lift $ Date <$> readPTime True defaultTimeLocale rfc822DateFormat , readPrec @Natural <&> Seconds . sec . fromIntegral @_ @RatioNat ] instance Buildable RetryAfter where build (Date d) = nameF "date" $ fromString $ formatTime defaultTimeLocale rfc822DateFormat d build (Seconds s) = nameF "seconds" $ show s -- | Determine whether the verification result contains a fixable error. isFixable :: VerifyError -> Bool isFixable (ExternalHttpTooManyRequests _) = True isFixable _ = False data NeedsCaching key = NoCaching | CacheUnderKey key -- | Perform concurrent traversal of the list with the caching mechanism. -- The function is semantically similar to @Control.Concurrent.Async.forConcurrently@; -- each asynchronous result of the @action@ is prepended to the accumulator list @[Async b]@. -- Additionally, these action results may also be inserted in a map of the type -- @Map cacheKey (Async b)@, depending on the return value of the function -- @a -> NeedsCaching cacheKey@ applied to each of the element from the given list. -- If an element of the type @a@ needs caching, and the value is already present in the map, -- then the @action@ will not be executed, and the value is added to the accumulator list. -- After the whole list has been traversed, the accumulator is traversed once again to ensure -- every asynchronous action is completed. forConcurrentlyCaching :: Ord cacheKey => [a] -> (a -> NeedsCaching cacheKey) -> (a -> IO b) -> IO [b] forConcurrentlyCaching list needsCaching action = go [] M.empty list where go acc cached (x : xs) = case needsCaching x of NoCaching -> do withAsync (action x) $ \b -> go (b : acc) cached xs CacheUnderKey cacheKey -> do case M.lookup cacheKey cached of Nothing -> do withAsync (action x) $ \b -> go (b : acc) (M.insert cacheKey b cached) xs Just b -> go (b : acc) cached xs go acc _ [] = for acc wait <&> reverse verifyRepo :: Given ColorMode => Rewrite -> VerifyConfig -> VerifyMode -> FilePath -> RepoInfo -> IO (VerifyResult $ WithReferenceLoc VerifyError) verifyRepo rw config@VerifyConfig{..} mode root repoInfo'@(RepoInfo files _) = do let toScan = do (file, fileInfo) <- M.toList files guard . not $ matchesGlobPatterns root vcNotScanned file case fileInfo of Just fi -> do ref <- _fiReferences fi return (file, ref) Nothing -> empty -- no support for such file, can do nothing progressRef <- newIORef $ initVerifyProgress (map snd toScan) accumulated <- loopAsyncUntil (printer progressRef) do forConcurrentlyCaching toScan ifExternalThenCache $ \(file, ref) -> verifyReference config mode progressRef repoInfo' root file ref return $ fold accumulated where printer :: IORef VerifyProgress -> IO () printer progressRef = do posixTime <- getPOSIXTime <&> posixTimeToTimeSecond progress <- atomicModifyIORef' progressRef $ \VerifyProgress{..} -> let prog = VerifyProgress{ vrExternal = checkTaskTimestamp posixTime vrExternal , .. } 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 shouldCheckLocType :: VerifyMode -> LocationType -> Bool shouldCheckLocType mode locType | isExternal locType = shouldCheckExternal mode | isLocal locType = shouldCheckLocal mode | otherwise = False verifyReference :: VerifyConfig -> VerifyMode -> IORef VerifyProgress -> RepoInfo -> FilePath -> FilePath -> Reference -> IO (VerifyResult $ WithReferenceLoc VerifyError) verifyReference config@VerifyConfig{..} mode progressRef (RepoInfo files dirs) root fileWithReference ref@Reference{..} = retryVerification 0 $ do let locType = locationType rLink if shouldCheckLocType mode locType then case locType of CurrentFileLoc -> checkRef rAnchor fileWithReference RelativeLoc -> checkRef rAnchor (normalise $ takeDirectory fileWithReference toString (canonizeLocalRef rLink)) AbsoluteLoc -> checkRef rAnchor (root <> toString rLink) ExternalLoc -> checkExternalResource config rLink OtherLoc -> verifying pass else return mempty where retryVerification :: Int -> IO (VerifyResult VerifyError) -> IO (VerifyResult $ WithReferenceLoc VerifyError) retryVerification numberOfRetries resIO = do res@(VerifyResult ves) <- resIO now <- getPOSIXTime <&> posixTimeToTimeSecond let toSeconds = \case Seconds s -> s -- Calculates the seconds left until @Retry-After@ date. -- Defaults to 0 if the date has already passed. Date date | utcTimeToTimeSecond date >= now -> utcTimeToTimeSecond date -:- now _ -> sec 0 let toRetry = any isFixable ves && numberOfRetries < vcMaxRetries currentRetryAfter = fromMaybe vcDefaultRetryAfter $ extractRetryAfterInfo res <&> toSeconds let moveProgress = alterOverallProgress numberOfRetries . alterProgressErrors res numberOfRetries atomicModifyIORef' progressRef $ \VerifyProgress{..} -> ( if isExternal $ locationType rLink then VerifyProgress{ vrExternal = let vrExternalAdvanced = moveProgress vrExternal in if toRetry then case pTaskTimestamp vrExternal of Just (TaskTimestamp ttc start) | currentRetryAfter +:+ now <= ttc +:+ start -> vrExternalAdvanced _ -> setTaskTimestamp currentRetryAfter now vrExternalAdvanced else vrExternalAdvanced, .. } else VerifyProgress{ vrLocal = moveProgress vrLocal, .. } , () ) if toRetry then do threadDelay currentRetryAfter retryVerification (numberOfRetries + 1) resIO else return $ fmap (WithReferenceLoc fileWithReference ref) res alterOverallProgress :: (Num a) => Int -> Progress a -> Progress a alterOverallProgress retryNumber | retryNumber > 0 = id | otherwise = incProgress alterProgressErrors :: (Num a) => VerifyResult VerifyError -> Int -> Progress a -> Progress a alterProgressErrors res@(VerifyResult ves) retryNumber | vcMaxRetries == 0 = if ok then id else incProgressUnfixableErrors | retryNumber == 0 = if ok then id else if fixable then incProgressFixableErrors else incProgressUnfixableErrors | retryNumber == vcMaxRetries = if ok then decProgressFixableErrors else fixableToUnfixable -- 0 < retryNumber < vcMaxRetries | otherwise = if ok then decProgressFixableErrors else if fixable then id else fixableToUnfixable where ok = verifyOk res fixable = any isFixable ves extractRetryAfterInfo :: VerifyResult VerifyError -> Maybe RetryAfter extractRetryAfterInfo = \case VerifyResult [ExternalHttpTooManyRequests retryAfter] -> retryAfter _ -> Nothing isVirtual = matchesGlobPatterns root vcVirtualFiles checkRef mAnchor referredFile = verifying $ unless (isVirtual referredFile) do checkReferredFileIsInsideRepo referredFile checkReferredFileExists referredFile case lookupFilePath referredFile $ M.toList files of Nothing -> pass -- no support for such file, can do nothing Just referredFileInfo -> whenJust mAnchor $ checkAnchor referredFile (_fiAnchors referredFileInfo) lookupFilePath :: FilePath -> [(FilePath, Maybe FileInfo)] -> Maybe FileInfo lookupFilePath fp = snd <=< find (equalFilePath (expandIndirections fp) . fst) -- expands ".." and "." -- expandIndirections "a/b/../c" = "a/c" -- expandIndirections "a/b/c/../../d" = "a/d" -- expandIndirections "../../a" = "../../a" -- expandIndirections "a/./b" = "a/b" -- expandIndirections "a/b/./../c" = "a/c" expandIndirections :: FilePath -> FilePath expandIndirections = joinPath . reverse . expand 0 . reverse . splitDirectories where expand :: Int -> [FilePath] -> [FilePath] expand acc ("..":xs) = expand (acc+1) xs expand acc (".":xs) = expand acc xs expand 0 (x:xs) = x : expand 0 xs expand acc (_:xs) = expand (acc-1) xs expand acc [] = replicate acc ".." checkReferredFileIsInsideRepo file = unless (noNegativeNesting $ makeRelative root file) $ throwError (LocalFileOutsideRepo file) where -- checks that relative filepath fully belongs to the root directory -- noNegativeNesting "a/../b" = True -- noNegativeNesting "a/../../b" = False noNegativeNesting path = all (>= 0) $ scanl (\n dir -> n + nestingChange dir) (0 :: Integer) $ splitDirectories path nestingChange ".." = -1 nestingChange "." = 0 nestingChange _ = 1 checkReferredFileExists file = do unless (fileExists || dirExists) $ throwError (LocalFileDoesNotExist file) where matchesFilePath :: FilePath -> Bool matchesFilePath = equalFilePath $ expandIndirections file fileExists :: Bool fileExists = any matchesFilePath $ M.keys files dirExists :: Bool dirExists = any matchesFilePath dirs checkAnchor file fileAnchors anchor = do checkAnchorReferenceAmbiguity file fileAnchors anchor checkDeduplicatedAnchorReference file fileAnchors anchor checkAnchorExists fileAnchors anchor -- Detect a case when original file contains two identical anchors, github -- has added a suffix to the duplicate, and now the original is referrenced - -- such links are pretty fragile and we discourage their use despite -- they are in fact unambiguous. checkAnchorReferenceAmbiguity file fileAnchors anchor = do let similarAnchors = filter ((== anchor) . aName) fileAnchors when (length similarAnchors > 1) $ throwError $ AmbiguousAnchorRef file anchor (Exts.fromList similarAnchors) -- Similar to the previous one, but for the case when we reference the -- renamed duplicate. checkDeduplicatedAnchorReference file fileAnchors anchor = whenJust (stripAnchorDupNo anchor) $ \origAnchor -> checkAnchorReferenceAmbiguity file fileAnchors origAnchor checkAnchorExists givenAnchors anchor = case find ((== anchor) . aName) givenAnchors of Just _ -> pass Nothing -> let isSimilar = (>= vcAnchorSimilarityThreshold) similarAnchors = filter (isSimilar . realToFrac . damerauLevenshteinNorm anchor . aName) givenAnchors in throwError $ AnchorDoesNotExist anchor similarAnchors -- | Parse URI according to RFC 3986 extended by allowing non-encoded -- `[` and `]` in query string. parseUri :: Text -> ExceptT VerifyError IO URI parseUri link = do -- There exist two main standards of URL parsing: RFC 3986 and the Web -- Hypertext Application Technology Working Group's URL standard. Ideally, -- we want to be able to parse the URLs in accordance with the latter -- standard, because it provides a much less ambiguous set of rules for -- percent-encoding special characters, and is essentially a living -- standard that gets updated constantly. -- -- We have chosen the 'uri-bytestring' library for URI parsing because -- of the 'laxURIParseOptions' parsing configuration. 'mkURI' from -- the 'modern-uri' library parses URIs in accordance with RFC 3986 and does -- not provide a means of parsing customization, which contrasts with -- 'parseURI' that accepts a 'URIParserOptions'. One of the predefined -- configurations of this type is 'strictURIParserOptions', which follows -- RFC 3986, and the other -- 'laxURIParseOptions' -- allows brackets -- in the queries, which draws us closer to the WHATWG URL standard. uri' <- URIBS.parseURI URIBS.laxURIParserOptions (encodeUtf8 link) & either (throwError . ExternalResourceInvalidUri) pure -- We stick to our infrastructure by continuing to operate on the datatypes -- from `modern-uri`, which are used in the 'req' library. First we -- serialize our URI parsed with 'parseURI' so it becomes a 'ByteString' -- with all the necessary special characters *percent-encoded*, and then -- call 'mkURIBs'. mkURIBs (URIBS.serializeURIRef' uri') -- Ideally, this exception should never be thrown, as the URI -- already *percent-encoded* with 'parseURI' from 'uri-bytestring' -- and 'mkURIBs' is only used to convert to 'URI' type from -- 'modern-uri' package. & handleJust (fromException @ParseExceptionBs) (throwError . ExternalResourceUriConversionError) checkExternalResource :: VerifyConfig -> Text -> IO (VerifyResult VerifyError) checkExternalResource VerifyConfig{..} link | isIgnored = return mempty | otherwise = fmap toVerifyRes $ runExceptT $ do uri <- parseUri link case toString <$> uriScheme uri of Just "http" -> checkHttp uri Just "https" -> checkHttp uri Just "ftp" -> checkFtp uri False Just "ftps" -> checkFtp uri True _ -> throwError ExternalResourceUnknownProtocol where isIgnored = doesMatchAnyRegex link vcIgnoreRefs doesMatchAnyRegex :: Text -> ([Regex] -> Bool) doesMatchAnyRegex src = any $ \regex -> case regexec regex src of Right res -> case res of Just (before, match, after, _) -> null before && null after && not (null match) Nothing -> False Left _ -> False checkHttp :: URI -> ExceptT VerifyError IO () checkHttp uri = makeHttpRequest uri HEAD 0.3 `catchError` \case e | isFixable e -> throwError e _ -> makeHttpRequest uri GET 0.7 makeHttpRequest :: (HttpMethod method, HttpBodyAllowed (AllowsBody method) 'NoBody) => URI -> method -> RatioNat -> ExceptT VerifyError IO () makeHttpRequest uri method timeoutFrac = do parsedUrl <- case useURI uri of -- accordingly to source code - Nothing can be only in case when -- protocol is not http or https, but we've checked it already -- so just in case we throw exception here Nothing -> throwError $ ExternalResourceInvalidUrl Nothing Just u -> pure u let reqLink = case parsedUrl of Left (url, option) -> runReq defaultHttpConfig $ req method url NoReqBody ignoreResponse option Right (url, option) -> runReq defaultHttpConfig $ req method url NoReqBody ignoreResponse option let maxTime = Time @Second $ unTime vcExternalRefCheckTimeout * timeoutFrac mres <- liftIO (timeout maxTime $ void reqLink) `catch` (either throwError (\() -> return (Just ())) . interpretErrors) maybe (throwError $ ExternalResourceSomeError "Response timeout") pure mres isAllowedErrorCode = or . sequence -- We have to stay conservative - if some URL can be accessed under -- some circumstances, we should do our best to report it as fine. [ if vcIgnoreAuthFailures -- unauthorized access then flip elem [403, 401] else const False , (405 ==) -- method mismatch ] interpretErrors = \case JsonHttpException _ -> error "External link JSON parse exception" VanillaHttpException err -> case err of InvalidUrlException{} -> error "External link URL invalid exception" HttpExceptionRequest _ exc -> case exc of StatusCodeException resp _ | isAllowedErrorCode (statusCode $ responseStatus resp) -> Right () | otherwise -> case statusCode (responseStatus resp) of 429 -> Left . ExternalHttpTooManyRequests $ retryAfterInfo resp _ -> Left . ExternalHttpResourceUnavailable $ responseStatus resp other -> Left . ExternalResourceSomeError $ show other where retryAfterInfo :: Response a -> Maybe RetryAfter retryAfterInfo = readMaybe . decodeUtf8 <=< L.lookup hRetryAfter . responseHeaders checkFtp :: URI -> Bool -> ExceptT VerifyError IO () checkFtp uri secure = do -- get authority which stores host and port authority <- case uriAuthority uri of Right a -> pure a Left _ -> throwError $ ExternalResourceInvalidUrl (Just "FTP path must be absolute") let host = toString $ authHost authority port :: Int <- case toIntegralSized . fromMaybe 21 $ authPort authority of Just p -> pure p Nothing -> throwError $ ExternalResourceInvalidUrl (Just "Bad port") -- build path from pieces path <- case uriPath uri of Nothing -> pure "" Just (_, pieces) -> pure . mconcat . intersperse "/" . map toString . toList $ pieces makeFtpRequest host port path secure `catch` \e -> throwError $ ExternalFtpException e makeFtpRequest :: String -> Int -> FilePath -> Bool -> ExceptT VerifyError IO () makeFtpRequest host port path secure = handler host port $ \handle response -> do -- check connection status when (frStatus response /= Success) $ throwError $ ExternalFtpResourceUnavailable response -- anonymous login loginResp <- login handle "anonymous" "" -- check login status when (frStatus loginResp /= Success) $ if vcIgnoreAuthFailures then pure () else throwError $ ExternalFtpException $ UnsuccessfulException loginResp -- If the response is non-null, the path is definitely a directory; -- If the response is null, the path may be a file or may not exist. dirList <- nlst handle [ "-a", path ] when (BS.null dirList) $ do -- The server-PI will respond to the SIZE command with a 213 reply -- giving the transfer size of the file whose pathname was supplied, -- or an error response if the file does not exist, the size is -- unavailable, or some other error has occurred. _ <- size handle path `catch` \case UnsuccessfulException _ -> throwError $ FtpEntryDoesNotExist path FailureException FTPResponse{..} | frCode == 550 -> throwError $ FtpEntryDoesNotExist path err -> liftIO $ throwIO err 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