Skip to content

Commit

Permalink
Merge pull request #209 from serokell/Sorokin-Anton/#89-handle-interr…
Browse files Browse the repository at this point in the history
…upts

[#89] Handle user interrupts
Sorokin-Anton authored Nov 16, 2022
2 parents c45f1ec + 4782c36 commit 2d83165
Showing 6 changed files with 96 additions and 43 deletions.
3 changes: 3 additions & 0 deletions .buildkite/pipeline.yml
Original file line number Diff line number Diff line change
@@ -30,6 +30,9 @@ steps:

- command: nix run -f ci.nix xrefcheck-static -c xrefcheck --ignore 'tests/markdowns/**/*' --ignore 'tests/golden/**/*'
label: Xrefcheck itself
retry:
automatic:
limit: 2

- label: lint
command: nix run -f ci.nix pkgs.haskellPackages.hlint -c hlint .
2 changes: 1 addition & 1 deletion package.yaml
Original file line number Diff line number Diff line change
@@ -85,7 +85,6 @@ library:
- data-default
- directory
- dlist
- exceptions
- filepath
- raw-strings-qq
- fmt
@@ -113,6 +112,7 @@ library:
- yaml
- reflection
- nyan-interpolation
- safe-exceptions

executables:
xrefcheck:
21 changes: 3 additions & 18 deletions src/Xrefcheck/Command.hs
Original file line number Diff line number Diff line change
@@ -23,11 +23,12 @@ import Xrefcheck.Config
import Xrefcheck.Core (Flavor (..))
import Xrefcheck.Progress (allowRewrite)
import Xrefcheck.Scan
(FormatsSupport, ScanError (..), ScanResult (..), scanRepo, specificFormatsSupport)
(FormatsSupport, ScanError (..), ScanResult (..), reportScanErrs, scanRepo,
specificFormatsSupport)
import Xrefcheck.Scanners.Markdown (markdownSupport)
import Xrefcheck.System (askWithinCI)
import Xrefcheck.Util
import Xrefcheck.Verify (verifyErrors, verifyRepo)
import Xrefcheck.Verify (reportVerifyErrs, verifyErrors, verifyRepo)

readConfig :: FilePath -> IO Config
readConfig path = fmap (normaliseConfigFilePaths . overrideConfig) do
@@ -92,19 +93,3 @@ defaultAction Options{..} = do
unless (null scanErrs) $ fmt "\n"
reportVerifyErrs verifyErrs
exitFailure
where
reportScanErrs errs = fmt
[int||
=== Scan errors found ===

#{interpolateIndentF 2 (interpolateBlockListF' "➥ " build errs)}
Scan errors dumped, #{length errs} in total.
|]

reportVerifyErrs errs = fmt
[int||
=== Invalid references found ===

#{interpolateIndentF 2 (interpolateBlockListF' "➥ " build errs)}
Invalid references dumped, #{length errs} in total.
|]
2 changes: 1 addition & 1 deletion src/Xrefcheck/Core.hs
Original file line number Diff line number Diff line change
@@ -328,7 +328,7 @@ data VerifyProgress = VerifyProgress
initVerifyProgress :: [Reference] -> VerifyProgress
initVerifyProgress references = VerifyProgress
{ vrLocal = initProgress (length localRefs)
, vrExternal = initProgress (length (L.nubBy ((==) `on` rLink) extRefs))
, vrExternal = initProgress (length (ordNub $ map rLink extRefs))
}
where
(extRefs, localRefs) = L.partition (isExternal . locationType . rLink) references
12 changes: 11 additions & 1 deletion src/Xrefcheck/Scan.hs
Original file line number Diff line number Diff line change
@@ -25,6 +25,7 @@ module Xrefcheck.Scan
, ecIgnoreLocalRefsToL
, ecIgnoreRefsFromL
, ecIgnoreExternalRefsToL
, reportScanErrs
) where

import Universum
@@ -34,7 +35,7 @@ import Data.Aeson (FromJSON (..), genericParseJSON, withText)
import Data.List qualified as L
import Data.Map qualified as M
import Data.Reflection (Given)
import Fmt (Buildable (..))
import Fmt (Buildable (..), fmt)
import System.Directory (doesDirectoryExist)
import System.FilePath
(dropTrailingPathSeparator, equalFilePath, splitDirectories, takeDirectory, takeExtension, (</>))
@@ -102,6 +103,15 @@ instance Given ColorMode => Buildable ScanError where

|]

reportScanErrs :: Given ColorMode => NonEmpty ScanError -> IO ()
reportScanErrs errs = fmt
[int||
=== Scan errors found ===

#{interpolateIndentF 2 (interpolateBlockListF' "➥ " build errs)}
Scan errors dumped, #{length errs} in total.
|]

data ScanErrorDescription
= LinkErr
| FileErr
99 changes: 77 additions & 22 deletions src/Xrefcheck/Verify.hs
Original file line number Diff line number Diff line change
@@ -5,7 +5,6 @@

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}

module Xrefcheck.Verify
( -- * General verification
@@ -29,13 +28,13 @@ module Xrefcheck.Verify

-- * URI parsing
, parseUri
, reportVerifyErrs
) where

import Universum

import Control.Concurrent.Async (async, wait, withAsync)
import Control.Exception (throwIO)
import Control.Monad.Catch (handleJust)
import Control.Concurrent.Async (async, cancel, wait, withAsync, Async, poll)
import Control.Exception (AsyncException (..), throwIO)
import Control.Monad.Except (MonadError (..))
import Data.ByteString qualified as BS
import Data.List qualified as L
@@ -45,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 (..), maybeF, nameF)
import Fmt (Buildable (..), fmt, maybeF, nameF)
import GHC.Exts qualified as Exts
import GHC.Read (Read (readPrec))
import Network.FTP.Client
@@ -74,6 +73,7 @@ import Xrefcheck.Progress
import Xrefcheck.Scan
import Xrefcheck.System
import Xrefcheck.Util
import Control.Exception.Safe (handleAsync, handleJust)

{-# ANN module ("HLint: ignore Use uncurry" :: Text) #-}
{-# ANN module ("HLint: ignore Use 'runExceptT' from Universum" :: Text) #-}
@@ -227,6 +227,17 @@ instance Given ColorMode => Buildable VerifyError where
⛂ #{err}
|]

reportVerifyErrs
:: Given ColorMode => NonEmpty (WithReferenceLoc VerifyError) -> IO ()
reportVerifyErrs errs = fmt
[int||
=== Invalid references found ===

#{interpolateIndentF 2 (interpolateBlockListF' "➥ " build errs)}
Invalid references dumped, #{length errs} in total.
|]


data RetryAfter = Date UTCTime | Seconds (Time Second)
deriving stock (Show, Eq)

@@ -260,22 +271,54 @@ data NeedsCaching key
-- 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.
-- If interrupted by AsyncException, returns this exception and list of already calcualted results
-- (their subset can be arbitrary). Computations that were not ended till this moment are cancelled.
forConcurrentlyCaching
:: Ord cacheKey
=> [a] -> (a -> NeedsCaching cacheKey) -> (a -> IO b) -> IO [b]
:: forall a b cacheKey. Ord cacheKey
=> [a] -> (a -> NeedsCaching cacheKey) -> (a -> IO b) -> IO (Either (AsyncException, [b]) [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
go
:: [Async b]
-> Map cacheKey (Async b)
-> [a]
-> IO (Either (AsyncException, [b]) [b])
go acc cached items =
case items of

(x : xs) -> case needsCaching x of
NoCaching -> 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
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

[] -> handleAsync
-- Wait for all children threads to complete.
--
-- If, while the threads are running, the user hits Ctrl+C,
-- a `UserInterrupt :: AsyncException` will be thrown onto the main thread.
-- We catch it here, cancel all child threads,
-- and return the results of only the threads that finished successfully.
(\case
UserInterrupt -> do
partialResults <- for acc \asyncAction -> do
cancel asyncAction
poll asyncAction <&> \case
Just (Right a) -> Just a
Just (Left _ex) -> Nothing
Nothing -> Nothing
pure $ Left (UserInterrupt, catMaybes partialResults)
otherAsyncEx -> throwM otherAsyncEx
)
$ Right . reverse <$> for acc wait
-- If action was already completed, then @cancel@ will have no effect, and we
-- will get result from @cancel f >> poll f@. Otherwise action will be interrupted,
-- so poll will return @Left (SomeException AsyncCancelled)@

verifyRepo
:: Given ColorMode
@@ -306,7 +349,19 @@ verifyRepo
accumulated <- loopAsyncUntil (printer progressRef) do
forConcurrentlyCaching toScan ifExternalThenCache $ \(file, ref) ->
verifyReference config mode progressRef repoInfo' root file ref
return $ fold accumulated
case accumulated of
Right res -> return $ fold res
Left (exception, partialRes) -> do
-- The user has hit Ctrl+C; display any verification errors we managed to find and exit.
let errs = verifyErrors (fold partialRes)
total = length toScan
checked = length partialRes
whenJust errs $ reportVerifyErrs
fmt [int|A|
Interrupted (#s{exception}), checked #{checked} out of #{total} references.
|]
exitFailure

where
printer :: IORef VerifyProgress -> IO ()
printer progressRef = do
@@ -681,26 +736,26 @@ checkExternalResource Config{..} link
-> Bool
-> ExceptT VerifyError IO ()
makeFtpRequest host port path secure = handler host port $
\handle response -> do
\ftpHandle response -> do
-- check connection status
when (frStatus response /= Success) $
throwError $ ExternalFtpResourceUnavailable response
-- anonymous login
loginResp <- login handle "anonymous" ""
loginResp <- login ftpHandle "anonymous" ""
-- check login status
when (frStatus loginResp /= Success) $
if ncIgnoreAuthFailures
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 ]
dirList <- nlst ftpHandle [ "-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
_ <- size ftpHandle path `catch` \case
UnsuccessfulException _ -> throwError $ FtpEntryDoesNotExist path
FailureException FTPResponse{..} | frCode == 550 ->
throwError $ FtpEntryDoesNotExist path

0 comments on commit 2d83165

Please sign in to comment.