git.iko.soy/hakyll
on e40e7fb help sign in
hakyll/src/Hakyll/Check.hs
199 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 $ getRecursiveContents (destinationDirectory config)
99 let htmls =
100 [ destinationDirectory config </> file
101 | file <- files
102 , takeExtension file == ".html"
103 ]
105 forM_ htmls checkFile
108--------------------------------------------------------------------------------
109checkFile :: FilePath -> Checker ()
110checkFile filePath = do
111 logger <- checkerLogger <$> ask
112 contents <- liftIO $ readFile filePath
113 Logger.header logger $ "Checking file " ++ filePath
115 let urls = getUrls $ TS.parseTags contents
116 forM_ urls $ \url -> do
117 Logger.debug logger $ "Checking link " ++ url
118 if isExternal url
119 then checkExternalUrl url
120 else checkInternalUrl filePath url
123--------------------------------------------------------------------------------
124ok :: String -> Checker ()
125ok _ = tell $ mempty {checkerOk = 1}
128--------------------------------------------------------------------------------
129faulty :: String -> Checker ()
130faulty url = do
131 logger <- checkerLogger <$> ask
132 Logger.error logger $ "Broken link to " ++ show url
133 tell $ mempty {checkerFaulty = 1}
136--------------------------------------------------------------------------------
137checkInternalUrl :: FilePath -> String -> Checker ()
138checkInternalUrl base url = case url' of
139 "" -> ok url
140 _ -> do
141 config <- checkerConfig <$> ask
142 let dest = destinationDirectory config
143 dir = takeDirectory base
144 filePath
145 | "/" `isPrefixOf` url' = dest ++ url'
146 | otherwise = dir </> url'
148 exists <- checkFileExists filePath
149 if exists then ok url else faulty url
150 where
151 url' = stripFragments url
154--------------------------------------------------------------------------------
155checkExternalUrl :: String -> Checker ()
156checkExternalUrl url = do
157 logger <- checkerLogger <$> ask
158 needsCheck <- (== All) . checkerCheck <$> ask
159 checked <- (url `S.member`) <$> get
161 if not needsCheck || checked
162 then Logger.debug logger "Already checked, skipping"
163 else do
164 isOk <- liftIO $ handle (failure logger) $
165 Http.withManager $ \mgr -> do
166 request <- Http.parseUrl url
167 response <- Http.http (settings request) mgr
168 let code = Http.statusCode (Http.responseStatus response)
169 return $ code >= 200 && code < 300
171 modify $ S.insert url
172 if isOk then ok url else faulty url
173 where
174 settings r = r
175 { Http.method = "HEAD"
176 , Http.redirectCount = 10
177 }
179 -- Catch all the things except UserInterrupt
180 failure logger (SomeException e) = case cast e of
181 Just UserInterrupt -> throw UserInterrupt
182 _ -> Logger.error logger (show e) >> return False
185--------------------------------------------------------------------------------
186-- | Wraps doesFileExist, also checks for index.html
187checkFileExists :: FilePath -> Checker Bool
188checkFileExists filePath = liftIO $ do
189 file <- doesFileExist filePath
190 dir <- doesDirectoryExist filePath
191 case (file, dir) of
192 (True, _) -> return True
193 (_, True) -> doesFileExist $ filePath </> "index.html"
194 _ -> return False
197--------------------------------------------------------------------------------
198stripFragments :: String -> String
199stripFragments = takeWhile (not . flip elem ['?', '#'])