blob: 550348bf3be0caeef88894f831e7a6fb92425fbb (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
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
|
