git.iko.soy/hakyll
on 2ef7fee help sign in
hakyll/src/Hakyll/Check.hs
250 lines 9.1 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 $ getRecursiveContents
113 (const $ return 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 checkUrl filePath url
137--------------------------------------------------------------------------------
138checkUrl :: FilePath -> String -> Checker ()
139checkUrl filePath url
140 | isExternal url = checkExternalUrl url
141 | hasProtocol url = skip "Unknown protocol, skipping"
142 | otherwise = checkInternalUrl filePath url
143 where
144 validProtoChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "+-."
145 hasProtocol str = case break (== ':') str of
146 (proto, ':' : _) -> all (`elem` validProtoChars) proto
147 _ -> False
150--------------------------------------------------------------------------------
151ok :: String -> Checker ()
152ok _ = tell $ mempty {checkerOk = 1}
155--------------------------------------------------------------------------------
156skip :: String -> Checker ()
157skip reason = do
158 logger <- checkerLogger <$> ask
159 Logger.debug logger $ reason
160 tell $ mempty {checkerOk = 1}
162--------------------------------------------------------------------------------
163faulty :: String -> Checker ()
164faulty url = do
165 logger <- checkerLogger <$> ask
166 Logger.error logger $ "Broken link to " ++ show url
167 tell $ mempty {checkerFaulty = 1}
170--------------------------------------------------------------------------------
171checkInternalUrl :: FilePath -> String -> Checker ()
172checkInternalUrl base url = case url' of
173 "" -> ok url
174 _ -> do
175 config <- checkerConfig <$> ask
176 let dest = destinationDirectory config
177 dir = takeDirectory base
178 filePath
179 | "/" `isPrefixOf` url' = dest ++ url'
180 | otherwise = dir </> url'
182 exists <- checkFileExists filePath
183 if exists then ok url else faulty url
184 where
185 url' = stripFragments url
188--------------------------------------------------------------------------------
189checkExternalUrl :: String -> Checker ()
190#ifdef CHECK_EXTERNAL
191checkExternalUrl url = do
192 logger <- checkerLogger <$> ask
193 needsCheck <- (== All) . checkerCheck <$> ask
194 checked <- (url `S.member`) <$> get
196 if not needsCheck || checked
197 then Logger.debug logger "Already checked, skipping"
198 else do
199 isOk <- liftIO $ handle (failure logger) $
200 Http.withManager $ \mgr -> do
201 request <- Http.parseUrl urlToCheck
202 response <- Http.http (settings request) mgr
203 let code = Http.statusCode (Http.responseStatus response)
204 return $ code >= 200 && code < 300
206 modify $ if schemeRelative url
207 then S.insert urlToCheck . S.insert url
208 else S.insert url
209 if isOk then ok url else faulty url
210 where
211 -- Add additional request info
212 settings r = r
213 { Http.method = "HEAD"
214 , Http.redirectCount = 10
215 , Http.requestHeaders = ("User-Agent", ua) : Http.requestHeaders r
216 }
218 -- Nice user agent info
219 ua = fromString $ "hakyll-check/" ++
220 (intercalate "." $ map show $ versionBranch $ Paths_hakyll.version)
222 -- Catch all the things except UserInterrupt
223 failure logger (SomeException e) = case cast e of
224 Just UserInterrupt -> throw UserInterrupt
225 _ -> Logger.error logger (show e) >> return False
227 -- Check scheme-relative links
228 schemeRelative = isPrefixOf "//"
229 urlToCheck = if schemeRelative url then "http:" ++ url else url
230#else
231checkExternalUrl _ = return ()
232#endif
236--------------------------------------------------------------------------------
237-- | Wraps doesFileExist, also checks for index.html
238checkFileExists :: FilePath -> Checker Bool
239checkFileExists filePath = liftIO $ do
240 file <- doesFileExist filePath
241 dir <- doesDirectoryExist filePath
242 case (file, dir) of
243 (True, _) -> return True
244 (_, True) -> doesFileExist $ filePath </> "index.html"
245 _ -> return False
248--------------------------------------------------------------------------------
249stripFragments :: String -> String
250stripFragments = takeWhile (not . flip elem ['?', '#'])