diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Changelog +## [0.2.0.0] - 2026-03-08 + +### Added + +* Check `` tags with `property="og:image"` or `name="twitter:image"` for broken image URLs. + ## [0.1.0.0] - 2022-05-09 ### Added diff --git a/linkcheck.cabal b/linkcheck.cabal --- a/linkcheck.cabal +++ b/linkcheck.cabal @@ -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 diff --git a/src/LinkCheck.hs b/src/LinkCheck.hs --- a/src/LinkCheck.hs +++ b/src/LinkCheck.hs @@ -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} diff --git a/src/LinkCheck/OptParse.hs b/src/LinkCheck/OptParse.hs --- a/src/LinkCheck/OptParse.hs +++ b/src/LinkCheck/OptParse.hs @@ -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 diff --git a/src/LinkCheck/OptParse/Types.hs b/src/LinkCheck/OptParse/Types.hs deleted file mode 100644 --- a/src/LinkCheck/OptParse/Types.hs +++ /dev/null @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented"