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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
--------------------------------------------------------------------------------
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 (doesDirectoryExist, 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
} deriving (Show)
--------------------------------------------------------------------------------
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.header logger $ show write
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
-- Lots of logic here...
urls = filter (not . null) $
map stripFragments $
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 <- checkFileExists filePath
if exists
then tell $ mempty {checkerOk = 1}
else do
tell $ mempty {checkerFaulty = 1}
Logger.error logger $ base ++ ": broken reference to " ++ show url
--------------------------------------------------------------------------------
-- | Wraps doesFileExist, also checks for index.html
checkFileExists :: FilePath -> Checker Bool
checkFileExists filePath = liftIO $ do
file <- doesFileExist filePath
dir <- doesDirectoryExist filePath
case (file, dir) of
(True, _) -> return True
(_, True) -> doesFileExist $ filePath </> "index.html"
_ -> return False
--------------------------------------------------------------------------------
stripFragments :: String -> String
stripFragments = takeWhile (not . flip elem ['?', '#'])
|
