git.iko.soy/hakyll
on b287c82 help sign in
hakyll/src/Hakyll/Check.hs
226 lines 8.2 kB history raw
1--------------------------------------------------------------------------------
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE OverloadedStrings #-}
4module Hakyll.Check
5 ( Check (..)
6 , check
7 ) where
10--------------------------------------------------------------------------------
11import Control.Applicative ((<$>))
12import Control.Monad (forM_)
13import Control.Monad.Reader (ask)
14import Control.Monad.RWS (RWST, runRWST)
15import Control.Monad.Trans (liftIO)
16import Control.Monad.Writer (tell)
17import Data.List (isPrefixOf)
18import Data.Monoid (Monoid (..))
19import Data.Set (Set)
20import qualified Data.Set as S
21import System.Directory (doesDirectoryExist, doesFileExist)
22import System.Exit (ExitCode (..))
23import System.FilePath (takeDirectory, takeExtension, (</>))
24import qualified Text.HTML.TagSoup as TS
27--------------------------------------------------------------------------------
28#ifdef CHECK_EXTERNAL
29import Control.Exception (AsyncException (..),
30 SomeException (..), handle, throw)
31import Control.Monad.State (get, modify)
32import Data.List (intercalate)
33import Data.Typeable (cast)
34import Data.Version (versionBranch)
35import GHC.Exts (fromString)
36import qualified Network.HTTP.Conduit as Http
37import qualified Network.HTTP.Types as Http
38import qualified Paths_hakyll as Paths_hakyll
39#endif
42--------------------------------------------------------------------------------
43import Hakyll.Core.Configuration
44import Hakyll.Core.Logger (Logger, Verbosity)
45import qualified Hakyll.Core.Logger as Logger
46import Hakyll.Core.Util.File
47import Hakyll.Web.Html
50--------------------------------------------------------------------------------
51data Check = All | InternalLinks
52 deriving (Eq, Ord, Show)
55--------------------------------------------------------------------------------
56check :: Configuration -> Verbosity -> Check -> IO ExitCode
57check config verbosity check' = do
58 ((), write) <- runChecker checkDestination config verbosity check'
59 return $ if checkerFaulty write >= 0 then ExitFailure 1 else ExitSuccess
62--------------------------------------------------------------------------------
63data CheckerRead = CheckerRead
64 { checkerConfig :: Configuration
65 , checkerLogger :: Logger
66 , checkerCheck :: Check
67 }
70--------------------------------------------------------------------------------
71data CheckerWrite = CheckerWrite
72 { checkerFaulty :: Int
73 , checkerOk :: Int
74 } deriving (Show)
77--------------------------------------------------------------------------------
78instance Monoid CheckerWrite where
79 mempty = CheckerWrite 0 0
80 mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) =
81 CheckerWrite (f1 + f2) (o1 + o2)
84--------------------------------------------------------------------------------
85type CheckerState = Set String
88--------------------------------------------------------------------------------
89type Checker a = RWST CheckerRead CheckerWrite CheckerState IO a
92--------------------------------------------------------------------------------
93runChecker :: Checker a -> Configuration -> Verbosity -> Check
94 -> IO (a, CheckerWrite)
95runChecker checker config verbosity check' = do
96 logger <- Logger.new verbosity
97 let read' = CheckerRead
98 { checkerConfig = config
99 , checkerLogger = logger
100 , checkerCheck = check'
101 }
103 (x, _, write) <- runRWST checker read' S.empty
104 Logger.flush logger
105 return (x, write)
108--------------------------------------------------------------------------------
109checkDestination :: Checker ()
110checkDestination = do
111 config <- checkerConfig <$> ask
112 files <- liftIO $
113 getRecursiveContents (const False) (destinationDirectory config)
115 let htmls =
116 [ destinationDirectory config </> file
117 | file <- files
118 , takeExtension file == ".html"
119 ]
121 forM_ htmls checkFile
124--------------------------------------------------------------------------------
125checkFile :: FilePath -> Checker ()
126checkFile filePath = do
127 logger <- checkerLogger <$> ask
128 contents <- liftIO $ readFile filePath
129 Logger.header logger $ "Checking file " ++ filePath
131 let urls = getUrls $ TS.parseTags contents
132 forM_ urls $ \url -> do
133 Logger.debug logger $ "Checking link " ++ url
134 if isExternal url
135 then checkExternalUrl url
136 else checkInternalUrl filePath url
139--------------------------------------------------------------------------------
140ok :: String -> Checker ()
141ok _ = tell $ mempty {checkerOk = 1}
144--------------------------------------------------------------------------------
145faulty :: String -> Checker ()
146faulty url = do
147 logger <- checkerLogger <$> ask
148 Logger.error logger $ "Broken link to " ++ show url
149 tell $ mempty {checkerFaulty = 1}
152--------------------------------------------------------------------------------
153checkInternalUrl :: FilePath -> String -> Checker ()
154checkInternalUrl base url = case url' of
155 "" -> ok url
156 _ -> do
157 config <- checkerConfig <$> ask
158 let dest = destinationDirectory config
159 dir = takeDirectory base
160 filePath
161 | "/" `isPrefixOf` url' = dest ++ url'
162 | otherwise = dir </> url'
164 exists <- checkFileExists filePath
165 if exists then ok url else faulty url
166 where
167 url' = stripFragments url
170--------------------------------------------------------------------------------
171checkExternalUrl :: String -> Checker ()
172#ifdef CHECK_EXTERNAL
173checkExternalUrl url = do
174 logger <- checkerLogger <$> ask
175 needsCheck <- (== All) . checkerCheck <$> ask
176 checked <- (url `S.member`) <$> get
178 if not needsCheck || checked
179 then Logger.debug logger "Already checked, skipping"
180 else do
181 isOk <- liftIO $ handle (failure logger) $
182 Http.withManager $ \mgr -> do
183 request <- Http.parseUrl url
184 response <- Http.http (settings request) mgr
185 let code = Http.statusCode (Http.responseStatus response)
186 return $ code >= 200 && code < 300
188 modify $ S.insert url
189 if isOk then ok url else faulty url
190 where
191 -- Add additional request info
192 settings r = r
193 { Http.method = "HEAD"
194 , Http.redirectCount = 10
195 , Http.requestHeaders = ("User-Agent", ua) : Http.requestHeaders r
196 }
198 -- Nice user agent info
199 ua = fromString $ "hakyll-check/" ++
200 (intercalate "." $ map show $ versionBranch $ Paths_hakyll.version)
202 -- Catch all the things except UserInterrupt
203 failure logger (SomeException e) = case cast e of
204 Just UserInterrupt -> throw UserInterrupt
205 _ -> Logger.error logger (show e) >> return False
206#else
207checkExternalUrl _ = return ()
208#endif
212--------------------------------------------------------------------------------
213-- | Wraps doesFileExist, also checks for index.html
214checkFileExists :: FilePath -> Checker Bool
215checkFileExists filePath = liftIO $ do
216 file <- doesFileExist filePath
217 dir <- doesDirectoryExist filePath
218 case (file, dir) of
219 (True, _) -> return True
220 (_, True) -> doesFileExist $ filePath </> "index.html"
221 _ -> return False
224--------------------------------------------------------------------------------
225stripFragments :: String -> String
226stripFragments = takeWhile (not . flip elem ['?', '#'])