Draft tool to check internal links
This commit is contained in:
parent
720c92ab1e
commit
5b1a675b94
7 changed files with 140 additions and 17 deletions
|
@ -138,6 +138,7 @@ Library
|
||||||
Hakyll.Web.Template.Read
|
Hakyll.Web.Template.Read
|
||||||
|
|
||||||
Other-Modules:
|
Other-Modules:
|
||||||
|
Hakyll.Check
|
||||||
Hakyll.Core.Compiler.Internal
|
Hakyll.Core.Compiler.Internal
|
||||||
Hakyll.Core.Compiler.Require
|
Hakyll.Core.Compiler.Require
|
||||||
Hakyll.Core.Item.SomeItem
|
Hakyll.Core.Item.SomeItem
|
||||||
|
|
106
src/Hakyll/Check.hs
Normal file
106
src/Hakyll/Check.hs
Normal file
|
@ -0,0 +1,106 @@
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
module Hakyll.Check
|
||||||
|
( runCheck
|
||||||
|
) where
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
import Control.Applicative ((<$>))
|
||||||
|
import Control.Monad (forM_)
|
||||||
|
import Control.Monad.Reader (ReaderT, ask, runReaderT)
|
||||||
|
import Control.Monad.Trans (liftIO)
|
||||||
|
import Control.Monad.Writer (WriterT, runWriterT, tell)
|
||||||
|
import Data.List (isPrefixOf)
|
||||||
|
import Data.Monoid (Monoid (..))
|
||||||
|
import System.Directory (doesFileExist)
|
||||||
|
import System.FilePath (takeDirectory, takeExtension, (</>))
|
||||||
|
import qualified Text.HTML.TagSoup as TS
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
import Hakyll.Core.Configuration
|
||||||
|
import Hakyll.Core.Logger (Logger)
|
||||||
|
import qualified Hakyll.Core.Logger as Logger
|
||||||
|
import Hakyll.Core.Util.File
|
||||||
|
import Hakyll.Web.Html
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
data CheckerRead = CheckerRead
|
||||||
|
{ checkerConfig :: Configuration
|
||||||
|
, checkerLogger :: Logger
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
data CheckerWrite = CheckerWrite
|
||||||
|
{ checkerFaulty :: Int
|
||||||
|
, checkerOk :: Int
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
instance Monoid CheckerWrite where
|
||||||
|
mempty = CheckerWrite 0 0
|
||||||
|
mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) =
|
||||||
|
CheckerWrite (f1 + f2) (o1 + o2)
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
type Checker a = ReaderT CheckerRead (WriterT CheckerWrite IO) a
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
runCheck :: Configuration -> IO ()
|
||||||
|
runCheck config = do
|
||||||
|
logger <- Logger.new (verbosity config)
|
||||||
|
let read' = CheckerRead config logger
|
||||||
|
((), _write) <- runWriterT $ runReaderT check read'
|
||||||
|
Logger.flush logger
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
check :: Checker ()
|
||||||
|
check = do
|
||||||
|
config <- checkerConfig <$> ask
|
||||||
|
files <- liftIO $ getRecursiveContents (destinationDirectory config)
|
||||||
|
|
||||||
|
let htmls =
|
||||||
|
[ destinationDirectory config </> file
|
||||||
|
| file <- files
|
||||||
|
, takeExtension file == ".html"
|
||||||
|
]
|
||||||
|
|
||||||
|
forM_ htmls checkFile
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
checkFile :: FilePath -> Checker ()
|
||||||
|
checkFile filePath = do
|
||||||
|
logger <- checkerLogger <$> ask
|
||||||
|
contents <- liftIO $ readFile filePath
|
||||||
|
|
||||||
|
Logger.header logger $ "Checking " ++ filePath
|
||||||
|
let tags = TS.parseTags contents
|
||||||
|
urls = filter (not . isExternal) $ getUrls tags
|
||||||
|
mapM_ (checkUrl filePath) urls
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
checkUrl :: FilePath -> String -> Checker ()
|
||||||
|
checkUrl base url = do
|
||||||
|
logger <- checkerLogger <$> ask
|
||||||
|
config <- checkerConfig <$> ask
|
||||||
|
|
||||||
|
let dest = destinationDirectory config
|
||||||
|
dir = takeDirectory base
|
||||||
|
filePath
|
||||||
|
| "/" `isPrefixOf` url = dest ++ url
|
||||||
|
| otherwise = dir </> url
|
||||||
|
|
||||||
|
exists <- liftIO $ doesFileExist filePath
|
||||||
|
if exists
|
||||||
|
then tell $ mempty {checkerOk = 1}
|
||||||
|
else do
|
||||||
|
tell $ mempty {checkerFaulty = 1}
|
||||||
|
Logger.error logger $ base ++ ": broken reference to " ++ url
|
|
@ -42,10 +42,10 @@ data Logger = Logger
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Create a new logger
|
-- | Create a new logger
|
||||||
new :: Verbosity -> (String -> IO ()) -> IO Logger
|
new :: Verbosity -> IO Logger
|
||||||
new vbty sink = do
|
new vbty = do
|
||||||
logger <- Logger <$>
|
logger <- Logger <$>
|
||||||
newChan <*> newEmptyMVar <*> pure sink <*> pure vbty
|
newChan <*> newEmptyMVar <*> pure putStrLn <*> pure vbty
|
||||||
_ <- forkIO $ loggerThread logger
|
_ <- forkIO $ loggerThread logger
|
||||||
return logger
|
return logger
|
||||||
where
|
where
|
||||||
|
|
|
@ -43,7 +43,7 @@ import Hakyll.Core.Writable
|
||||||
run :: Configuration -> Rules a -> IO RuleSet
|
run :: Configuration -> Rules a -> IO RuleSet
|
||||||
run config rules = do
|
run config rules = do
|
||||||
-- Initialization
|
-- Initialization
|
||||||
logger <- Logger.new (verbosity config) putStrLn
|
logger <- Logger.new (verbosity config)
|
||||||
Logger.header logger "Initialising..."
|
Logger.header logger "Initialising..."
|
||||||
Logger.message logger "Creating store..."
|
Logger.message logger "Creating store..."
|
||||||
store <- Store.new (inMemoryCache config) $ storeDirectory config
|
store <- Store.new (inMemoryCache config) $ storeDirectory config
|
||||||
|
|
|
@ -16,6 +16,7 @@ import System.Process (system)
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
import Hakyll.Check
|
||||||
import Hakyll.Core.Configuration
|
import Hakyll.Core.Configuration
|
||||||
import Hakyll.Core.Rules
|
import Hakyll.Core.Rules
|
||||||
import Hakyll.Core.Runtime
|
import Hakyll.Core.Runtime
|
||||||
|
@ -47,6 +48,7 @@ hakyllWith conf rules = do
|
||||||
args <- getArgs
|
args <- getArgs
|
||||||
case args of
|
case args of
|
||||||
["build"] -> build conf rules
|
["build"] -> build conf rules
|
||||||
|
["check"] -> check conf
|
||||||
["clean"] -> clean conf
|
["clean"] -> clean conf
|
||||||
["help"] -> help
|
["help"] -> help
|
||||||
["preview"] -> preview conf rules 8000
|
["preview"] -> preview conf rules 8000
|
||||||
|
@ -66,6 +68,12 @@ build conf rules = do
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | Run the checker
|
||||||
|
check :: Configuration -> IO ()
|
||||||
|
check = runCheck
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Remove the output directories
|
-- | Remove the output directories
|
||||||
clean :: Configuration -> IO ()
|
clean :: Configuration -> IO ()
|
||||||
|
|
|
@ -8,6 +8,7 @@ module Hakyll.Web.Html
|
||||||
, demoteHeaders
|
, demoteHeaders
|
||||||
|
|
||||||
-- * Url manipulation
|
-- * Url manipulation
|
||||||
|
, getUrls
|
||||||
, withUrls
|
, withUrls
|
||||||
, toUrl
|
, toUrl
|
||||||
, toSiteRoot
|
, toSiteRoot
|
||||||
|
@ -20,16 +21,14 @@ module Hakyll.Web.Html
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Data.Char (digitToInt, intToDigit, isDigit, toLower)
|
import Data.Char (digitToInt, intToDigit,
|
||||||
import Data.List (isPrefixOf)
|
isDigit, toLower)
|
||||||
import qualified Data.Set as S
|
import Data.List (isPrefixOf)
|
||||||
import System.FilePath (joinPath, splitPath, takeDirectory)
|
import System.FilePath (joinPath, splitPath,
|
||||||
import Text.Blaze.Html (toHtml)
|
takeDirectory)
|
||||||
import Text.Blaze.Html.Renderer.String (renderHtml)
|
import Text.Blaze.Html (toHtml)
|
||||||
|
import Text.Blaze.Html.Renderer.String (renderHtml)
|
||||||
|
import qualified Text.HTML.TagSoup as TS
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
import qualified Text.HTML.TagSoup as TS
|
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -52,6 +51,16 @@ demoteHeaders = withTags $ \tag -> case tag of
|
||||||
demote t = t
|
demote t = t
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
isUrlAttribute :: String -> Bool
|
||||||
|
isUrlAttribute = (`elem` ["src", "href"])
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
getUrls :: [TS.Tag String] -> [String]
|
||||||
|
getUrls tags = [v | TS.TagOpen _ as <- tags, (k, v) <- as, isUrlAttribute k]
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Apply a function to each URL on a webpage
|
-- | Apply a function to each URL on a webpage
|
||||||
withUrls :: (String -> String) -> String -> String
|
withUrls :: (String -> String) -> String -> String
|
||||||
|
@ -59,8 +68,7 @@ withUrls f = withTags tag
|
||||||
where
|
where
|
||||||
tag (TS.TagOpen s a) = TS.TagOpen s $ map attr a
|
tag (TS.TagOpen s a) = TS.TagOpen s $ map attr a
|
||||||
tag x = x
|
tag x = x
|
||||||
attr (k, v) = (k, if k `S.member` refs then f v else v)
|
attr (k, v) = (k, if isUrlAttribute k then f v else v)
|
||||||
refs = S.fromList ["src", "href"]
|
|
||||||
|
|
||||||
|
|
||||||
-- | Customized TagSoup renderer. (The default TagSoup renderer escape CSS
|
-- | Customized TagSoup renderer. (The default TagSoup renderer escape CSS
|
||||||
|
|
|
@ -68,7 +68,7 @@ newTestProvider store = newProvider store (const False) "tests/data"
|
||||||
testCompiler :: Store -> Provider -> Identifier -> Compiler a
|
testCompiler :: Store -> Provider -> Identifier -> Compiler a
|
||||||
-> IO (CompilerResult a)
|
-> IO (CompilerResult a)
|
||||||
testCompiler store provider underlying compiler = do
|
testCompiler store provider underlying compiler = do
|
||||||
logger <- Logger.new Logger.Debug (\_ -> return ())
|
logger <- Logger.new Logger.Error
|
||||||
let read' = CompilerRead
|
let read' = CompilerRead
|
||||||
{ compilerUnderlying = underlying
|
{ compilerUnderlying = underlying
|
||||||
, compilerProvider = provider
|
, compilerProvider = provider
|
||||||
|
|
Loading…
Reference in a new issue