@@ -0,0 +1,106 @@
1+--------------------------------------------------------------------------------
2+module Hakyll.Check
3+ ( runCheck
4+ ) where
5+
6+
7+--------------------------------------------------------------------------------
8+import Control.Applicative ((<$>))
9+import Control.Monad (forM_)
10+import Control.Monad.Reader (ReaderT, ask, runReaderT)
11+import Control.Monad.Trans (liftIO)
12+import Control.Monad.Writer (WriterT, runWriterT, tell)
13+import Data.List (isPrefixOf)
14+import Data.Monoid (Monoid (..))
15+import System.Directory (doesFileExist)
16+import System.FilePath (takeDirectory, takeExtension, (</>))
17+import qualified Text.HTML.TagSoup as TS
18+
19+
20+--------------------------------------------------------------------------------
21+import Hakyll.Core.Configuration
22+import Hakyll.Core.Logger (Logger)
23+import qualified Hakyll.Core.Logger as Logger
24+import Hakyll.Core.Util.File
25+import Hakyll.Web.Html
26+
27+
28+--------------------------------------------------------------------------------
29+data CheckerRead = CheckerRead
30+ { checkerConfig :: Configuration
31+ , checkerLogger :: Logger
32+ }
33+
34+
35+--------------------------------------------------------------------------------
36+data CheckerWrite = CheckerWrite
37+ { checkerFaulty :: Int
38+ , checkerOk :: Int
39+ }
40+
41+
42+--------------------------------------------------------------------------------
43+instance Monoid CheckerWrite where
44+ mempty = CheckerWrite 0 0
45+ mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) =
46+ CheckerWrite (f1 + f2) (o1 + o2)
47+
48+
49+--------------------------------------------------------------------------------
50+type Checker a = ReaderT CheckerRead (WriterT CheckerWrite IO) a
51+
52+
53+--------------------------------------------------------------------------------
54+runCheck :: Configuration -> IO ()
55+runCheck config = do
56+ logger <- Logger.new (verbosity config)
57+ let read' = CheckerRead config logger
58+ ((), _write) <- runWriterT $ runReaderT check read'
59+ Logger.flush logger
60+
61+
62+--------------------------------------------------------------------------------
63+check :: Checker ()
64+check = do
65+ config <- checkerConfig <$> ask
66+ files <- liftIO $ getRecursiveContents (destinationDirectory config)
67+
68+ let htmls =
69+ [ destinationDirectory config </> file
70+ | file <- files
71+ , takeExtension file == ".html"
72+ ]
73+
74+ forM_ htmls checkFile
75+
76+
77+--------------------------------------------------------------------------------
78+checkFile :: FilePath -> Checker ()
79+checkFile filePath = do
80+ logger <- checkerLogger <$> ask
81+ contents <- liftIO $ readFile filePath
82+
83+ Logger.header logger $ "Checking " ++ filePath
84+ let tags = TS.parseTags contents
85+ urls = filter (not . isExternal) $ getUrls tags
86+ mapM_ (checkUrl filePath) urls
87+
88+
89+--------------------------------------------------------------------------------
90+checkUrl :: FilePath -> String -> Checker ()
91+checkUrl base url = do
92+ logger <- checkerLogger <$> ask
93+ config <- checkerConfig <$> ask
94+
95+ let dest = destinationDirectory config
96+ dir = takeDirectory base
97+ filePath
98+ | "/" `isPrefixOf` url = dest ++ url
99+ | otherwise = dir </> url
100+
101+ exists <- liftIO $ doesFileExist filePath
102+ if exists
103+ then tell $ mempty {checkerOk = 1}
104+ else do
105+ tell $ mempty {checkerFaulty = 1}
106+ Logger.error logger $ base ++ ": broken reference to " ++ url