croque-mort (empty) → 0.1.0.0
raw patch · 5 files changed
+510/−0 lines, 5 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, containers, directory, filepath, html-entities, optparse-applicative, poolboy, scalpel, text
Files
- LICENSE +15/−0
- app/Domain.hs +236/−0
- app/FileSystem.hs +53/−0
- app/Main.hs +151/−0
- croque-mort.cabal +55/−0
+ LICENSE view
@@ -0,0 +1,15 @@+ISC License++Copyright (c) 2025 Gautier DI FOLCO++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY+AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM+LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR+OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR+PERFORMANCE OF THIS SOFTWARE.
+ app/Domain.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE NoFieldSelectors #-}++module Domain+ ( Folder (..),+ RemoteBaseURL (..),+ Link (..),+ originalLink,+ parseLink,+ ParsedLinks (..),+ WithRootFolder (..),+ LinkReport (..),+ LinkStatus (..),+ CheckedLinks (..),+ checkLinks,+ BrokenLinks (..),+ filterBrokenLinks,+ hasBrokenLinks,+ Summary (..),+ SummaryPhase (..),+ mkSummary,+ )+where++import Data.Aeson+import qualified Data.Char as Char+import Data.List (isPrefixOf, isSuffixOf)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TL+import GHC.Generics+import HTMLEntities.Decoder (htmlEncodedText)+import qualified System.FilePath as Path++newtype Folder+ = Folder {unFolder :: FilePath}+ deriving stock (Eq, Ord, Show, Generic)+ deriving newtype (ToJSON, ToJSONKey)++newtype RemoteBaseURL+ = RemoteBaseURL {unRemoteBaseURL :: T.Text}+ deriving stock (Eq, Ord, Show, Generic)+ deriving newtype (ToJSON, ToJSONKey)++data Link+ = LocalLink T.Text FilePath+ | RemoteLink T.Text T.Text+ deriving stock (Eq, Ord, Show, Generic)++originalLink :: Link -> T.Text+originalLink =+ \case+ LocalLink o _ -> o+ RemoteLink o _ -> o++linkOptions :: Options+linkOptions =+ defaultOptions+ { sumEncoding =+ TaggedObject+ { tagFieldName = "type",+ contentsFieldName = "link"+ }+ }++instance ToJSON Link where+ toJSON = genericToJSON linkOptions+ toEncoding = genericToEncoding linkOptions++parseLink :: T.Text -> Maybe Link+parseLink raw+ | "#" `T.isPrefixOf` raw || T.null (T.strip raw) = Nothing+ | "javascript:" `T.isPrefixOf` raw || "data:" `T.isPrefixOf` raw = Nothing+ | "https://" `T.isPrefixOf` clean || "http://" `T.isPrefixOf` clean = Just $ RemoteLink raw clean+ | otherwise = Just $ LocalLink raw $ T.unpack clean+ where+ clean = T.takeWhile (`notElem` ['#', '?']) $ TL.toStrict $ TL.toLazyText $ htmlEncodedText raw++newtype ParsedLinks+ = ParsedLinks {unParsedLinks :: Map.Map RemoteBaseURL (WithRootFolder (Map.Map FilePath [Link]))}+ deriving stock (Eq, Ord, Show, Generic)+ deriving newtype (ToJSON)++data WithRootFolder a = WithRootFolder+ { root :: Folder,+ links :: a+ }+ deriving stock (Eq, Ord, Show, Generic, Functor)+ deriving anyclass (ToJSON)++data LinkReport = LinkReport+ { link :: Link,+ status :: LinkStatus+ }+ deriving stock (Eq, Ord, Show, Generic)+ deriving anyclass (ToJSON)++data LinkStatus+ = Skipped+ | Valid+ | Broken+ deriving stock (Eq, Ord, Show, Generic)++instance Semigroup LinkStatus where+ Skipped <> x = x+ x <> Skipped = x+ _ <> Valid = Valid+ Valid <> _ = Valid+ Broken <> Broken = Broken++linkStatusOptions :: Options+linkStatusOptions =+ defaultOptions+ { constructorTagModifier = map Char.toLower+ }++instance ToJSON LinkStatus where+ toJSON = genericToJSON linkStatusOptions+ toEncoding = genericToEncoding linkStatusOptions++newtype CheckedLinks+ = CheckedLinks {unCheckedLinks :: Map.Map RemoteBaseURL (WithRootFolder (Map.Map FilePath [LinkReport]))}+ deriving stock (Eq, Ord, Show, Generic)+ deriving newtype (ToJSON)++checkLinks :: ParsedLinks -> CheckedLinks+checkLinks (ParsedLinks links) =+ CheckedLinks $+ Map.map+ ( \withRoot ->+ WithRootFolder+ { root = withRoot.root,+ links = Map.filter (not . null) $ Map.mapWithKey (map . checkLink withRoot.root) withRoot.links+ }+ )+ links+ where+ checkLink (Folder root) file link =+ LinkReport+ { link = link,+ status =+ let fixIndex targetFile+ | null targetFile = "index.html"+ | "/" `isSuffixOf` targetFile = targetFile <> "index.html"+ | otherwise = targetFile+ in case link of+ LocalLink _ localLink ->+ let targetFile = fixIndex localLink+ fullFile =+ Path.normalise $+ if "/" `isPrefixOf` targetFile+ then root Path.</> ("." <> targetFile)+ else Path.takeDirectory file Path.</> targetFile+ in if any (Map.member fullFile . (.links)) $ Map.elems links+ then Valid+ else Broken+ RemoteLink _ remoteLink ->+ let checkRemote (RemoteBaseURL remoteBase) withRoot =+ flip fmap (T.stripPrefix remoteBase remoteLink) $ \subFile ->+ let targetFile = fixIndex $ T.unpack $ fromMaybe subFile $ T.stripPrefix "/" subFile+ in if Map.member (Path.normalise $ withRoot.root.unFolder Path.</> targetFile) withRoot.links+ then Valid+ else Broken+ in fromMaybe Skipped $+ Map.foldlWithKey'+ (\acc remoteBase withRoot -> acc <> checkRemote remoteBase withRoot)+ Nothing+ links+ }++newtype BrokenLinks+ = BrokenLinks {unBrokenLinks :: Map.Map RemoteBaseURL (WithRootFolder (Map.Map FilePath [Link]))}+ deriving stock (Eq, Ord, Show, Generic)+ deriving newtype (ToJSON)++filterBrokenLinks :: CheckedLinks -> BrokenLinks+filterBrokenLinks (CheckedLinks checked) =+ BrokenLinks $+ Map.filter (not . null . (.links)) $+ Map.map (fmap $ Map.filter (not . null) . Map.map (map (.link) . filter ((== Broken) . (.status)))) checked++hasBrokenLinks :: BrokenLinks -> Bool+hasBrokenLinks (BrokenLinks broken) = not $ Map.null broken++data Summary = Summary+ { parsing :: SummaryPhase,+ checking :: SummaryPhase,+ broken :: SummaryPhase+ }+ deriving stock (Eq, Ord, Show, Generic)+ deriving anyclass (ToJSON)++data SummaryPhase = SummaryPhase+ { remoteBaseURLs :: Int,+ files :: Int,+ links :: Int,+ linksSkipped :: Maybe Int,+ linksValid :: Maybe Int,+ linksBroken :: Maybe Int+ }+ deriving stock (Eq, Ord, Show, Generic)+ deriving anyclass (ToJSON)++mkSummary :: ParsedLinks -> CheckedLinks -> BrokenLinks -> Summary+mkSummary (ParsedLinks parsed) (CheckedLinks checked) (BrokenLinks broken) =+ Summary+ { parsing =+ phase parsed $ const (Nothing, Nothing, Nothing),+ checking =+ phase checked $ \allLinks ->+ ( Just $ length $ filter ((== Skipped) . (.status)) allLinks,+ Just $ length $ filter ((== Valid) . (.status)) allLinks,+ Just $ length $ filter ((== Broken) . (.status)) allLinks+ ),+ broken =+ phase broken $ \allLinks -> (Nothing, Nothing, Just $ length allLinks)+ }+ where+ phase ::+ Map.Map RemoteBaseURL (WithRootFolder (Map.Map FilePath [a])) ->+ ([a] -> (Maybe Int, Maybe Int, Maybe Int)) ->+ SummaryPhase+ phase nestedMap getStats =+ let allFiles = map (.links) $ Map.elems nestedMap+ allLinks = concat $ concatMap Map.elems allFiles+ (skippedCount, validCount, brokenCount) = getStats allLinks+ in SummaryPhase+ { remoteBaseURLs = Map.size nestedMap,+ files = sum $ map Map.size allFiles,+ links = length allLinks,+ linksSkipped = skippedCount,+ linksValid = validCount,+ linksBroken = brokenCount+ }
+ app/FileSystem.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE TupleSections #-}++module FileSystem+ ( parseLinks,++ -- * Tests+ pureParseLinks,+ )+where++import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Poolboy (defaultPoolboySettings)+import Data.Poolboy.Tactics (concurrentRecursive')+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Domain+import System.Directory (doesFileExist, listDirectory)+import System.FilePath (takeExtension, (</>))+import Text.HTML.Scalpel++parseLinks :: [(RemoteBaseURL, Folder)] -> IO ParsedLinks+parseLinks targets = do+ let go ::+ (RemoteBaseURL, Folder, FilePath) ->+ IO ([(RemoteBaseURL, Folder, FilePath)], [(RemoteBaseURL, WithRootFolder (Map.Map FilePath [Link]))])+ go (remoteBase, root, path) = do+ isFile <- doesFileExist path+ if isFile+ then do+ links <-+ if takeExtension path == ".html"+ then pureParseLinks <$> T.readFile path+ else return []+ return ([], [(remoteBase, WithRootFolder root $ Map.singleton path links)])+ else do+ entries <- listDirectory path+ return ((remoteBase,root,) . (path </>) <$> entries, [])+ ParsedLinks . Map.fromListWith (\x y -> WithRootFolder x.root $ x.links <> y.links) . concat+ <$> concurrentRecursive'+ defaultPoolboySettings+ (map go)+ ((map $ \(remoteBase, root) -> go (remoteBase, root, root.unFolder)) targets)++pureParseLinks :: T.Text -> [Link]+pureParseLinks input = fromMaybe [] $ scrapeStringLike input getLinks+ where+ getLinks :: Scraper T.Text [Link]+ getLinks = do+ meta <- chroot "head" $ attrs "href" "link"+ body <- chroot "body" $ (<>) <$> attrs "href" "a" <*> attrs "img" "src"+ script <- attrs "src" "script"+ return $ concatMap (mapMaybe parseLink) [meta, body, script]
+ app/Main.hs view
@@ -0,0 +1,151 @@+module Main (main) where++import Control.Monad (forM_, when)+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.Char as Char+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Domain+import FileSystem+import Options.Applicative+import System.Exit (exitFailure)++main :: IO ()+main = do+ cmd <- customExecParser (prefs showHelpOnEmpty) commandInfo+ case cmd of+ Run {..} -> do+ parsed <- parseLinks targets+ let checked = checkLinks parsed+ broken = filterBrokenLinks checked+ summary = mkSummary parsed checked broken++ case verbosity of+ LogMuted -> return ()+ LogSummary ->+ case format of+ Plain -> do+ when (hasBrokenLinks broken) $ do+ putStrLn "# Broken links"++ forM_ broken.unBrokenLinks $ \withRoot ->+ forM_ (Map.toList withRoot.links) $ \(file, links) ->+ forM_ links $ \link ->+ putStrLn $ file <> ":" <> T.unpack (originalLink link)++ putStrLn ""++ putStrLn $+ "Run over "+ <> show summary.parsing.remoteBaseURLs+ <> " base URLs"+ <> " and "+ <> show summary.parsing.files+ <> " files,"+ <> " only "+ <> show summary.broken.links+ <> " links where broken out of "+ <> show summary.parsing.links+ Json ->+ LBS.putStr $ Aeson.encode summary+ LogDetailed ->+ LBS.putStr $+ Aeson.encode $+ Aeson.object+ [ "parsing" Aeson..= parsed,+ "checking" Aeson..= checked,+ "broken" Aeson..= broken,+ "summary" Aeson..= summary+ ]++ when (hasBrokenLinks broken) exitFailure++-- * CLI++data Command+ = Run {verbosity :: Verbosity, format :: Format, targets :: [(RemoteBaseURL, Folder)]}++data Verbosity+ = LogMuted+ | LogSummary+ | LogDetailed+ deriving stock (Eq, Show)++data Format+ = Plain+ | Json+ deriving stock (Eq, Show)++commandInfo :: ParserInfo Command+commandInfo =+ info+ (commandParser <**> helper)+ ( fullDesc+ <> header hopHeader+ <> progDesc hopDesc+ )++commandParser :: Parser Command+commandParser =+ hsubparser+ ( command+ "run"+ ( info+ (Run <$> verbosityP <*> formatP <*> many targetP)+ (progDesc "Look for broken links")+ )+ )+ where+ verbosityP =+ flag'+ LogSummary+ ( long "verbose"+ <> short 'v'+ <> help "Display summary"+ )+ <|> flag'+ LogDetailed+ ( long "very-verbose"+ <> short 'V'+ <> help "Display summary and each phase details (json)"+ )+ <|> pure LogMuted+ formatP =+ option+ ( maybeReader $+ \case+ "plain" -> Just Plain+ "json" -> Just Json+ _ -> Nothing+ )+ ( long "format"+ <> value Plain+ <> showDefaultWith (map Char.toLower . show)+ <> metavar "FORMAT"+ <> help "Output format (plain|json)"+ )+ targetP =+ (,)+ <$> option+ (RemoteBaseURL <$> str)+ ( long "remote-base-url"+ <> short 'u'+ <> metavar "URL"+ <> help "Remote base URL (e.g. https://example.org/ping/)"+ )+ <*> option+ (Folder <$> str)+ ( long "directory"+ <> short 'd'+ <> metavar "DIRECTORY_PATH"+ <> help "Directory to the HTML (e.g. build/public)"+ )++-- * Meta++hopHeader :: String+hopHeader = "croque-mort - Dead simple broken links checker on local HTML folders"++hopDesc :: String+hopDesc = "A CLI to check broken links in HTML folders"
+ croque-mort.cabal view
@@ -0,0 +1,55 @@+cabal-version: 3.0+name: croque-mort+version: 0.1.0.0+author: Gautier DI FOLCO+maintainer: foss@difolco.dev+category: Data+build-type: Simple+license: ISC+license-file: LICENSE+synopsis: Dead simple broken links checker on local HTML folders+description: Dead simple broken links checker on local HTML folders.+Homepage: http://github.com/blackheaven/croque-mort++executable croque-mort+ -- type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Domain+ FileSystem+ hs-source-dirs: app+ default-extensions:+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ OverloadedRecordDot+ OverloadedStrings+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ build-depends:+ base >=4.19 && <5+ , aeson ==2.*+ , bytestring >= 0.10 && <0.13+ , containers >= 0.5 && <1+ , directory == 1.3.*+ , filepath >= 1.3 && <1.6+ , html-entities == 1.1.*+ , optparse-applicative >= 0.17 && <0.20+ , poolboy >= 0.4.1.0 && <0.5+ , scalpel == 0.6.*+ , text == 2.*+ default-language: Haskell2010