git.iko.soy/hakyll
on 52802ed help sign in
hakyll/src/Hakyll/Check.hs
200 lines 7.3 kB history raw
1--------------------------------------------------------------------------------
2{-# LANGUAGE OverloadedStrings #-}
3module Hakyll.Check
4 ( Check (..)
5 , check
6 ) where
9--------------------------------------------------------------------------------
10import Control.Applicative ((<$>))
11import Control.Exception (AsyncException (..),
12 SomeException (..), handle, throw)
13import Control.Monad (forM_)
14import Control.Monad.Reader (ask)
15import Control.Monad.RWS (RWST, runRWST)
16import Control.Monad.State (get, modify)
17import Control.Monad.Trans (liftIO)
18import Control.Monad.Writer (tell)
19import Data.List (isPrefixOf)
20import Data.Monoid (Monoid (..))
21import Data.Set (Set)
22import qualified Data.Set as S
23import Data.Typeable (cast)
24import qualified Network.HTTP.Conduit as Http
25import qualified Network.HTTP.Types as Http
26import System.Directory (doesDirectoryExist, doesFileExist)
27import System.Exit (ExitCode (..))
28import System.FilePath (takeDirectory, takeExtension, (</>))
29import qualified Text.HTML.TagSoup as TS
32--------------------------------------------------------------------------------
33import Hakyll.Core.Configuration
34import Hakyll.Core.Logger (Logger, Verbosity)
35import qualified Hakyll.Core.Logger as Logger
36import Hakyll.Core.Util.File
37import Hakyll.Web.Html
40--------------------------------------------------------------------------------
41data Check = All | InternalLinks
42 deriving (Eq, Ord, Show)
45--------------------------------------------------------------------------------
46check :: Configuration -> Verbosity -> Check -> IO ExitCode
47check config verbosity check' = do
48 ((), write) <- runChecker checkDestination config verbosity check'
49 return $ if checkerFaulty write >= 0 then ExitFailure 1 else ExitSuccess
52--------------------------------------------------------------------------------
53data CheckerRead = CheckerRead
54 { checkerConfig :: Configuration
55 , checkerLogger :: Logger
56 , checkerCheck :: Check
57 }
60--------------------------------------------------------------------------------
61data CheckerWrite = CheckerWrite
62 { checkerFaulty :: Int
63 , checkerOk :: Int
64 } deriving (Show)
67--------------------------------------------------------------------------------
68instance Monoid CheckerWrite where
69 mempty = CheckerWrite 0 0
70 mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) =
71 CheckerWrite (f1 + f2) (o1 + o2)
74--------------------------------------------------------------------------------
75type CheckerState = Set String
78--------------------------------------------------------------------------------
79type Checker a = RWST CheckerRead CheckerWrite CheckerState IO a
82--------------------------------------------------------------------------------
83runChecker :: Checker a -> Configuration -> Verbosity -> Check
84 -> IO (a, CheckerWrite)
85runChecker checker config verbosity check' = do
86 logger <- Logger.new verbosity
87 let read' = CheckerRead config logger check'
88 (x, _, write) <- runRWST checker read' S.empty
89 Logger.flush logger
90 return (x, write)
93--------------------------------------------------------------------------------
94checkDestination :: Checker ()
95checkDestination = do
96 config <- checkerConfig <$> ask
97 files <- liftIO $
98 getRecursiveContents (const False) (destinationDirectory config)
100 let htmls =
101 [ destinationDirectory config </> file
102 | file <- files
103 , takeExtension file == ".html"
104 ]
106 forM_ htmls checkFile
109--------------------------------------------------------------------------------
110checkFile :: FilePath -> Checker ()
111checkFile filePath = do
112 logger <- checkerLogger <$> ask
113 contents <- liftIO $ readFile filePath
114 Logger.header logger $ "Checking file " ++ filePath
116 let urls = getUrls $ TS.parseTags contents
117 forM_ urls $ \url -> do
118 Logger.debug logger $ "Checking link " ++ url
119 if isExternal url
120 then checkExternalUrl url
121 else checkInternalUrl filePath url
124--------------------------------------------------------------------------------
125ok :: String -> Checker ()
126ok _ = tell $ mempty {checkerOk = 1}
129--------------------------------------------------------------------------------
130faulty :: String -> Checker ()
131faulty url = do
132 logger <- checkerLogger <$> ask
133 Logger.error logger $ "Broken link to " ++ show url
134 tell $ mempty {checkerFaulty = 1}
137--------------------------------------------------------------------------------
138checkInternalUrl :: FilePath -> String -> Checker ()
139checkInternalUrl base url = case url' of
140 "" -> ok url
141 _ -> do
142 config <- checkerConfig <$> ask
143 let dest = destinationDirectory config
144 dir = takeDirectory base
145 filePath
146 | "/" `isPrefixOf` url' = dest ++ url'
147 | otherwise = dir </> url'
149 exists <- checkFileExists filePath
150 if exists then ok url else faulty url
151 where
152 url' = stripFragments url
155--------------------------------------------------------------------------------
156checkExternalUrl :: String -> Checker ()
157checkExternalUrl url = do
158 logger <- checkerLogger <$> ask
159 needsCheck <- (== All) . checkerCheck <$> ask
160 checked <- (url `S.member`) <$> get
162 if not needsCheck || checked
163 then Logger.debug logger "Already checked, skipping"
164 else do
165 isOk <- liftIO $ handle (failure logger) $
166 Http.withManager $ \mgr -> do
167 request <- Http.parseUrl url
168 response <- Http.http (settings request) mgr
169 let code = Http.statusCode (Http.responseStatus response)
170 return $ code >= 200 && code < 300
172 modify $ S.insert url
173 if isOk then ok url else faulty url
174 where
175 settings r = r
176 { Http.method = "HEAD"
177 , Http.redirectCount = 10
178 }
180 -- Catch all the things except UserInterrupt
181 failure logger (SomeException e) = case cast e of
182 Just UserInterrupt -> throw UserInterrupt
183 _ -> Logger.error logger (show e) >> return False
186--------------------------------------------------------------------------------
187-- | Wraps doesFileExist, also checks for index.html
188checkFileExists :: FilePath -> Checker Bool
189checkFileExists filePath = liftIO $ do
190 file <- doesFileExist filePath
191 dir <- doesDirectoryExist filePath
192 case (file, dir) of
193 (True, _) -> return True
194 (_, True) -> doesFileExist $ filePath </> "index.html"
195 _ -> return False
198--------------------------------------------------------------------------------
199stripFragments :: String -> String
200stripFragments = takeWhile (not . flip elem ['?', '#'])