linkcheck 0.1.0.0 → 0.2.0.0
raw patch · 6 files changed
+176/−192 lines, 6 filesdep +list-tdep +opt-env-confdep +stm-containersdep −optparse-applicative
Dependencies added: list-t, opt-env-conf, stm-containers, validity-network-uri
Dependencies removed: optparse-applicative
Files
- CHANGELOG.md +6/−0
- linkcheck.cabal +8/−19
- src/LinkCheck.hs +84/−46
- src/LinkCheck/OptParse.hs +78/−99
- src/LinkCheck/OptParse/Types.hs +0/−26
- test/Spec.hs +0/−2
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Changelog +## [0.2.0.0] - 2026-03-08++### Added++* Check `<meta>` tags with `property="og:image"` or `name="twitter:image"` for broken image URLs.+ ## [0.1.0.0] - 2022-05-09 ### Added
linkcheck.cabal view
@@ -1,19 +1,19 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7.+-- This file has been generated from package.yaml by hpack version 0.38.2. -- -- see: https://github.com/sol/hpack ----- hash: 552da3e14c9345725ae9f5e3e956caeb6dbecabee2df7e81c939a9eae9ce2f53+-- hash: c4572d1f18f5023bc2017ff15d83d0fd2c1330a48896a18725cb11725624109f name: linkcheck-version: 0.1.0.0+version: 0.2.0.0 synopsis: Check for broken links in CI homepage: https://github.com/NorfairKing/linkcheck#readme bug-reports: https://github.com/NorfairKing/linkcheck/issues author: Tom Sydney Kerckhove maintainer: syd@cs-syd.eu-copyright: Copyright (c) 2020-2022 Tom Sydney Kerckhove+copyright: Copyright (c) 2020-2024 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple@@ -29,7 +29,6 @@ exposed-modules: LinkCheck LinkCheck.OptParse- LinkCheck.OptParse.Types other-modules: Paths_linkcheck hs-source-dirs:@@ -43,18 +42,21 @@ , http-client , http-client-tls , http-types+ , list-t , lrucache , monad-logger , mtl , network-uri- , optparse-applicative+ , opt-env-conf , path , path-io , retry , stm+ , stm-containers , tagsoup , text , unliftio+ , validity-network-uri default-language: Haskell2010 executable linkcheck@@ -64,19 +66,6 @@ hs-source-dirs: app ghc-options: -threaded -rtsopts -with-rtsopts=-N -optP-Wno-nonportable-include-path- build-depends:- base >=4.7 && <5- , linkcheck- default-language: Haskell2010--test-suite linkcheck-test- type: exitcode-stdio-1.0- main-is: Spec.hs- other-modules:- Paths_linkcheck- hs-source-dirs:- test- ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 , linkcheck
src/LinkCheck.hs view
@@ -10,7 +10,6 @@ where import Control.Concurrent-import Control.Concurrent.STM (stateTVar) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger@@ -19,26 +18,25 @@ import qualified Data.ByteString.Lazy as LB import Data.Cache.LRU (LRU, newLRU) import qualified Data.Cache.LRU as LRU-import Data.IntMap (IntMap)-import qualified Data.IntMap.Strict as IM-import Data.Map (Map)-import qualified Data.Map as M import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as S import Data.String import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Tuple+import Data.Validity.URI import Data.Version import LinkCheck.OptParse+import qualified ListT import Network.HTTP.Client as HTTP+import Network.HTTP.Client.Internal (getRedirectedRequest, httpRaw, httpRedirect) import Network.HTTP.Client.Internal as HTTP (toHttpException) import Network.HTTP.Client.TLS as HTTP import Network.HTTP.Types as HTTP import Network.URI import Paths_linkcheck+import qualified StmContainers.Map as StmMap+import qualified StmContainers.Set as StmSet import System.Exit import Text.HTML.TagSoup import Text.Printf@@ -55,26 +53,29 @@ let headers = ( "User-Agent", TE.encodeUtf8 $ T.pack $ "linkcheck-" <> showVersion version- ) :- requestHeaders request+ )+ : requestHeaders request pure $ request {requestHeaders = headers} } man <- liftIO $ HTTP.newManager managerSets queue <- newTQueueIO- seen <- newTVarIO S.empty+ seen <- StmSet.newIO mCache <- if setCheckFragments then fmap Just $ newTVarIO $- newLRU $ fromIntegral <$> setCacheSize+ newLRU $+ fromIntegral <$> setCacheSize else pure Nothing -- no need to cache anything if we don't check fragments anyway.- results <- newTVarIO M.empty+ results <- StmMap.newIO fetchers <- case setFetchers of Nothing -> getNumCapabilities Just f -> pure f let indexes = [0 .. fetchers - 1]- fetcherStati <- newTVarIO $ IM.fromList $ zip indexes (repeat True)+ fetcherStati <- StmMap.newIO+ forM_ (zip indexes (repeat True)) $ \(ix, b) ->+ atomically $ StmMap.insert b ix fetcherStati atomically $ writeTQueue queue QueueURI {queueURI = setUri, queueURIDepth = 0, queueURITrace = []} runStderrLoggingT $ filterLogger (\_ ll -> ll >= setLogLevel) $ do@@ -101,14 +102,14 @@ workerSetTotalFetchers = fetchers, workerSetWorkerIndex = ix }- resultsList <- M.toList <$> readTVarIO results+ resultsList <- atomically $ ListT.toList $ StmMap.listT results unless (null resultsList) $ die $ unlines $ map ( \(uri, result) -> unwords- [ show uri,+ [ T.unpack uri, prettyResult result ] )@@ -129,9 +130,9 @@ prettyResult :: Result -> String prettyResult Result {..} = do unlines- ( unwords ["Reason:", prettyResultReason resultReason] :- "Trace:" :- map show resultTrace+ ( unwords ["Reason:", prettyResultReason resultReason]+ : "Trace:"+ : map show resultTrace ) prettyResultReason :: ResultReason -> String@@ -147,10 +148,10 @@ workerSetRoot :: !URI, workerSetHTTPManager :: !HTTP.Manager, workerSetURIQueue :: !(TQueue QueueURI),- workerSetSeenSet :: !(TVar (Set URI)),+ workerSetSeenSet :: !(StmSet.Set Text), workerSetCache :: !(Maybe (TVar (LRU URI [SB.ByteString]))),- workerSetResultsMap :: !(TVar (Map URI Result)),- workerSetStatusMap :: !(TVar (IntMap Bool)),+ workerSetResultsMap :: !(StmMap.Map Text Result),+ workerSetStatusMap :: !(StmMap.Map Int Bool), workerSetTotalFetchers :: !Int, workerSetWorkerIndex :: !Int }@@ -173,13 +174,16 @@ digits = ceiling (logBase 10 (fromIntegral workerSetTotalFetchers) :: Double) formatStr = "%0" <> show digits <> "d" in T.pack $ "fetcher-" <> printf formatStr workerSetWorkerIndex- setStatus b = atomically $ modifyTVar' workerSetStatusMap $ IM.insert workerSetWorkerIndex b+ setStatus b = atomically $ StmMap.insert b workerSetWorkerIndex workerSetStatusMap setBusy = setStatus True setIdle = setStatus False- allDone :: MonadIO m => m Bool- allDone = all not <$> readTVarIO workerSetStatusMap+ allDone :: (MonadIO m) => m Bool+ allDone = not . any snd <$> atomically (ListT.toList (StmMap.listT workerSetStatusMap)) go busy = do- mv <- atomically $ tryReadTQueue workerSetURIQueue+ mv <-+ if busy+ then atomically $ tryReadTQueue workerSetURIQueue+ else timeout 100_000 (atomically $ readTQueue workerSetURIQueue) -- Get an item off the queue case mv of -- No items on the queue@@ -194,9 +198,7 @@ when busy setIdle -- If all workers are idle, we are done. ad <- allDone- unless ad $ do- liftIO $ threadDelay 10000 -- 10 ms- go False+ unless ad $ go False -- An item on the queue Just QueueURI {..} -> do -- Set this worker as busy@@ -208,7 +210,8 @@ ] unless busy setBusy -- Check if the uri has been seen already- alreadySeen <- atomically $ S.member queueURI <$> readTVar workerSetSeenSet+ let queueURIText = T.pack $ dangerousURIToString queueURI+ alreadySeen <- atomically $ StmSet.lookup queueURIText workerSetSeenSet if alreadySeen then do -- We've already seen it, don't do anything.@@ -220,20 +223,20 @@ ] else do -- We haven't seen it yet. Mark it as seen.- atomically $ modifyTVar' workerSetSeenSet $ S.insert queueURI+ atomically $ StmSet.insert queueURIText workerSetSeenSet -- Helper function for inserting a result. -- We'll need this in both the cached and uncached branches below -- so we'll already define it here. let insertResult reason = atomically $- modifyTVar' workerSetResultsMap $- M.insert- queueURI- Result- { resultReason = reason,- resultTrace = queueURITrace- }+ StmMap.insert+ Result+ { resultReason = reason,+ resultTrace = queueURITrace+ }+ queueURIText+ workerSetResultsMap -- Check if the response is cached let cacheURI = queueURI {uriFragment = ""}@@ -282,7 +285,12 @@ show queueURI ] logInfoN $ T.pack $ concat fetchingLog- errOrResp <- liftIO $ retryHTTP req $ httpLbs req workerSetHTTPManager+ let externalPredicate =+ if workerSetExternal+ then const True+ else -- Filter out the ones that are not on the same host.+ (== uriAuthority workerSetRoot) . uriAuthority+ errOrResp <- liftIO $ retryHTTP req $ httpWithRedirects externalPredicate req workerSetHTTPManager case errOrResp of -- Something went wrong during the fetch. Left err -> do@@ -307,8 +315,9 @@ show queueURI <> ": ", show sci ]- -- If the status code is not in the 2XX range, add it to the results- unless (200 <= sci && sci < 300) $ insertResult $ ResultReasonStatus status+ -- If the status code is not in the 2XX or 3XX ranges, add it to the results+ -- 300 means either "too many redirects" or "the redirect is to somewhere external".+ unless (200 <= sci && sci < 400) $ insertResult $ ResultReasonStatus status -- Read the entire response and parse tags let body = LB.toStrict $ responseBody resp@@ -332,11 +341,6 @@ mapMaybe (fmap T.unpack . rightToMaybe . TE.decodeUtf8') $ mapMaybe aTagHref tags - let predicate =- if workerSetExternal- then const True- else -- Filter out the ones that are not on the same host.- (== uriAuthority workerSetRoot) . uriAuthority let urisToAddToQueue = map ( \u ->@@ -346,7 +350,7 @@ queueURITrace = queueURI : queueURITrace } )- $ filter predicate uris+ $ filter externalPredicate uris atomically $ mapM_ (writeTQueue workerSetURIQueue) urisToAddToQueue -- Compute the fragments@@ -398,8 +402,18 @@ TagOpen "a" as -> lookup "href" as TagOpen "link" as -> lookup "href" as TagOpen "img" as -> lookup "src" as+ TagOpen "meta" as -> metaImageContent as _ -> Nothing +-- | Extract the content attribute from meta tags that reference images.+-- Covers og:image, twitter:image, and similar.+metaImageContent :: (Eq str, IsString str) => [(str, str)] -> Maybe str+metaImageContent as = do+ let prop = lookup "property" as+ name = lookup "name" as+ guard $ prop == Just "og:image" || name == Just "twitter:image"+ lookup "content" as+ tagIdOrName :: (Eq str, IsString str) => Tag str -> [str] tagIdOrName = \case TagOpen _ as -> maybeToList (lookup "id" as) ++ maybeToList (lookup "name" as)@@ -435,3 +449,27 @@ _ -> False InvalidUrlException _ _ -> False couldBeFlaky _ = False++httpWithRedirects :: (URI -> Bool) -> Request -> HTTP.Manager -> IO (Response LB.ByteString)+httpWithRedirects externalPredicate request man = httpRedirect 10 go request >>= consumeBody+ where+ go :: HTTP.Request -> IO (Response HTTP.BodyReader, Maybe HTTP.Request)+ go r = do+ response <- httpRaw r man+ pure+ ( response,+ do+ newReq <-+ getRedirectedRequest+ request+ r+ (responseHeaders response)+ (responseCookieJar response)+ (statusCode (responseStatus response))+ guard $ externalPredicate (getUri newReq)+ pure newReq+ )++ consumeBody res = do+ bss <- brConsume $ responseBody res+ return res {responseBody = LB.fromChunks bss}
src/LinkCheck/OptParse.hs view
@@ -1,116 +1,95 @@+{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE RecordWildCards #-} module LinkCheck.OptParse- ( module LinkCheck.OptParse,- module LinkCheck.OptParse.Types,+ ( getSettings,+ Settings (..), ) where import Control.Monad.Logger-import Data.Maybe-import LinkCheck.OptParse.Types import Network.URI-import Options.Applicative-import qualified System.Environment as System+import OptEnvConf+import Paths_linkcheck (version) import Text.Read getSettings :: IO Settings-getSettings = do- flags <- getFlags- deriveSettings flags--deriveSettings :: Flags -> IO Settings-deriveSettings Flags {..} = do- let setUri = flagUri- setLogLevel = fromMaybe LevelInfo flagLogLevel- setFetchers = flagFetchers- setExternal = fromMaybe False flagExternal- setCheckFragments = fromMaybe False flagCheckFragments- setMaxDepth = flagMaxDepth- setCacheSize = flagCacheSize- pure Settings {..}--getFlags :: IO Flags-getFlags = do- args <- System.getArgs- let result = runArgumentsParser args- handleParseResult result--runArgumentsParser :: [String] -> ParserResult Flags-runArgumentsParser = execParserPure prefs_ flagsParser- where- prefs_ =- defaultPrefs- { prefShowHelpOnError = True,- prefShowHelpOnEmpty = True- }+getSettings = runSettingsParser version "Check links on a website" -flagsParser :: ParserInfo Flags-flagsParser = info (helper <*> parseFlags) fullDesc+data Settings = Settings+ { setUri :: !URI,+ setLogLevel :: !LogLevel,+ setFetchers :: !(Maybe Int),+ setExternal :: !Bool,+ setCheckFragments :: !Bool,+ setMaxDepth :: !(Maybe Word),+ setCacheSize :: !(Maybe Word)+ }+ deriving (Show, Eq) -parseFlags :: Parser Flags-parseFlags =- Flags- <$> argument- (maybeReader parseAbsoluteURI)- ( mconcat- [ help "The root uri. This must be an absolute URI. For example: https://example.com or http://localhost:8000",- metavar "URI"+instance HasParser Settings where+ settingsParser = do+ setUri <-+ setting+ [ help "The root uri. This must be an absolute URI.",+ reader $ maybeReader parseAbsoluteURI,+ argument,+ metavar "URI",+ example "https://example.com",+ example "http://localhost:8000"+ ]+ setLogLevel <-+ setting+ [ help "Minimal severity of log messages",+ reader $ maybeReader parseLogLevel,+ option,+ long "log-level",+ metavar "LOG_LEVEL",+ value LevelInfo+ ]+ setFetchers <-+ optional $+ setting+ [ help "The number of threads to fetch from. This application is usually not CPU bound so you can comfortably set this higher than the number of cores you have",+ reader auto,+ option,+ long "fetchers",+ metavar "NUM" ]- )- <*> option- (Just <$> maybeReader parseLogLevel)- ( mconcat- [ long "log-level",- help $ "The log level, example values: " <> show (map (drop 5 . show) [LevelDebug, LevelInfo, LevelWarn, LevelError]),- metavar "LOG_LEVEL",- value Nothing- ]- )- <*> optional- ( option- auto- ( mconcat- [ long "fetchers",- help "The number of threads to fetch from. This application is usually not CPU bound so you can comfortably set this higher than the number of cores you have",- metavar "INT"- ]- )- )- <*> optional- ( switch- ( mconcat- [ long "external",- help "Also check external links"- ]- )- )- <*> optional- ( switch- ( mconcat- [ long "check-fragments",- help "Also check that the URIs' fragment occurs on the page"- ]- )- )- <*> optional- ( option- auto- ( mconcat- [ long "max-depth",- help "Stop looking after reaching this number of links from the root"- ]- )- )- <*> optional- ( option- auto- ( mconcat- [ long "cache-size",- help "Cache this many requests' fragments."- ]- )- )+ setExternal <-+ setting+ [ help "Also check external links",+ switch True,+ long "external",+ value False+ ]+ setCheckFragments <-+ setting+ [ help "Also check that the URIs' fragment occurs on the page",+ switch True,+ long "check-fragments",+ value False+ ]+ setMaxDepth <-+ optional $+ setting+ [ help "Stop looking after reaching this number of links from the root",+ reader auto,+ option,+ long "max-depth",+ metavar "NUM"+ ]+ setCacheSize <-+ optional $+ setting+ [ help "Cache this many requests' fragments.",+ reader auto,+ option,+ long "cache-size",+ metavar "NUM"+ ]++ pure Settings {..} parseLogLevel :: String -> Maybe LogLevel parseLogLevel s = readMaybe $ "Level" <> s
− src/LinkCheck/OptParse/Types.hs
@@ -1,26 +0,0 @@-module LinkCheck.OptParse.Types where--import Control.Monad.Logger-import Network.URI--data Flags = Flags- { flagUri :: !URI,- flagLogLevel :: !(Maybe LogLevel),- flagFetchers :: !(Maybe Int),- flagExternal :: !(Maybe Bool),- flagCheckFragments :: !(Maybe Bool),- flagMaxDepth :: !(Maybe Word),- flagCacheSize :: !(Maybe Word)- }- deriving (Show, Eq)--data Settings = Settings- { setUri :: !URI,- setLogLevel :: !LogLevel,- setFetchers :: !(Maybe Int),- setExternal :: !Bool,- setCheckFragments :: !Bool,- setMaxDepth :: !(Maybe Word),- setCacheSize :: !(Maybe Word)- }- deriving (Show, Eq)
− test/Spec.hs
@@ -1,2 +0,0 @@-main :: IO ()-main = putStrLn "Test suite not yet implemented"