git.iko.soy/hakyll
on bc360a3 help sign in
hakyll/src/Hakyll/Check.hs
251 lines 9.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 Network.URI (unEscapeString)
22import System.Directory (doesDirectoryExist, doesFileExist)
23import System.Exit (ExitCode (..))
24import System.FilePath (takeDirectory, takeExtension, (</>))
25import qualified Text.HTML.TagSoup as TS
28--------------------------------------------------------------------------------
29#ifdef CHECK_EXTERNAL
30import Control.Exception (AsyncException (..),
31 SomeException (..), handle, throw)
32import Control.Monad.State (get, modify)
33import Data.List (intercalate)
34import Data.Typeable (cast)
35import Data.Version (versionBranch)
36import GHC.Exts (fromString)
37import qualified Network.HTTP.Conduit as Http
38import qualified Network.HTTP.Types as Http
39import qualified Paths_hakyll as Paths_hakyll
40#endif
43--------------------------------------------------------------------------------
44import Hakyll.Core.Configuration
45import Hakyll.Core.Logger (Logger, Verbosity)
46import qualified Hakyll.Core.Logger as Logger
47import Hakyll.Core.Util.File
48import Hakyll.Web.Html
51--------------------------------------------------------------------------------
52data Check = All | InternalLinks
53 deriving (Eq, Ord, Show)
56--------------------------------------------------------------------------------
57check :: Configuration -> Verbosity -> Check -> IO ExitCode
58check config verbosity check' = do
59 ((), write) <- runChecker checkDestination config verbosity check'
60 return $ if checkerFaulty write >= 0 then ExitFailure 1 else ExitSuccess
63--------------------------------------------------------------------------------
64data CheckerRead = CheckerRead
65 { checkerConfig :: Configuration
66 , checkerLogger :: Logger
67 , checkerCheck :: Check
68 }
71--------------------------------------------------------------------------------
72data CheckerWrite = CheckerWrite
73 { checkerFaulty :: Int
74 , checkerOk :: Int
75 } deriving (Show)
78--------------------------------------------------------------------------------
79instance Monoid CheckerWrite where
80 mempty = CheckerWrite 0 0
81 mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) =
82 CheckerWrite (f1 + f2) (o1 + o2)
85--------------------------------------------------------------------------------
86type CheckerState = Set String
89--------------------------------------------------------------------------------
90type Checker a = RWST CheckerRead CheckerWrite CheckerState IO a
93--------------------------------------------------------------------------------
94runChecker :: Checker a -> Configuration -> Verbosity -> Check
95 -> IO (a, CheckerWrite)
96runChecker checker config verbosity check' = do
97 logger <- Logger.new verbosity
98 let read' = CheckerRead
99 { checkerConfig = config
100 , checkerLogger = logger
101 , checkerCheck = check'
102 }
104 (x, _, write) <- runRWST checker read' S.empty
105 Logger.flush logger
106 return (x, write)
109--------------------------------------------------------------------------------
110checkDestination :: Checker ()
111checkDestination = do
112 config <- checkerConfig <$> ask
113 files <- liftIO $ getRecursiveContents
114 (const $ return False) (destinationDirectory config)
116 let htmls =
117 [ destinationDirectory config </> file
118 | file <- files
119 , takeExtension file == ".html"
120 ]
122 forM_ htmls checkFile
125--------------------------------------------------------------------------------
126checkFile :: FilePath -> Checker ()
127checkFile filePath = do
128 logger <- checkerLogger <$> ask
129 contents <- liftIO $ readFile filePath
130 Logger.header logger $ "Checking file " ++ filePath
132 let urls = getUrls $ TS.parseTags contents
133 forM_ urls $ \url -> do
134 Logger.debug logger $ "Checking link " ++ url
135 checkUrl filePath url
138--------------------------------------------------------------------------------
139checkUrl :: FilePath -> String -> Checker ()
140checkUrl filePath url
141 | isExternal url = checkExternalUrl url
142 | hasProtocol url = skip "Unknown protocol, skipping"
143 | otherwise = checkInternalUrl filePath url
144 where
145 validProtoChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "+-."
146 hasProtocol str = case break (== ':') str of
147 (proto, ':' : _) -> all (`elem` validProtoChars) proto
148 _ -> False
151--------------------------------------------------------------------------------
152ok :: String -> Checker ()
153ok _ = tell $ mempty {checkerOk = 1}
156--------------------------------------------------------------------------------
157skip :: String -> Checker ()
158skip reason = do
159 logger <- checkerLogger <$> ask
160 Logger.debug logger $ reason
161 tell $ mempty {checkerOk = 1}
163--------------------------------------------------------------------------------
164faulty :: String -> Checker ()
165faulty url = do
166 logger <- checkerLogger <$> ask
167 Logger.error logger $ "Broken link to " ++ show url
168 tell $ mempty {checkerFaulty = 1}
171--------------------------------------------------------------------------------
172checkInternalUrl :: FilePath -> String -> Checker ()
173checkInternalUrl base url = case url' of
174 "" -> ok url
175 _ -> do
176 config <- checkerConfig <$> ask
177 let dest = destinationDirectory config
178 dir = takeDirectory base
179 filePath
180 | "/" `isPrefixOf` url' = dest ++ url'
181 | otherwise = dir </> url'
183 exists <- checkFileExists filePath
184 if exists then ok url else faulty url
185 where
186 url' = stripFragments $ unEscapeString url
189--------------------------------------------------------------------------------
190checkExternalUrl :: String -> Checker ()
191#ifdef CHECK_EXTERNAL
192checkExternalUrl url = do
193 logger <- checkerLogger <$> ask
194 needsCheck <- (== All) . checkerCheck <$> ask
195 checked <- (url `S.member`) <$> get
197 if not needsCheck || checked
198 then Logger.debug logger "Already checked, skipping"
199 else do
200 isOk <- liftIO $ handle (failure logger) $
201 Http.withManager $ \mgr -> do
202 request <- Http.parseUrl urlToCheck
203 response <- Http.http (settings request) mgr
204 let code = Http.statusCode (Http.responseStatus response)
205 return $ code >= 200 && code < 300
207 modify $ if schemeRelative url
208 then S.insert urlToCheck . S.insert url
209 else S.insert url
210 if isOk then ok url else faulty url
211 where
212 -- Add additional request info
213 settings r = r
214 { Http.method = "HEAD"
215 , Http.redirectCount = 10
216 , Http.requestHeaders = ("User-Agent", ua) : Http.requestHeaders r
217 }
219 -- Nice user agent info
220 ua = fromString $ "hakyll-check/" ++
221 (intercalate "." $ map show $ versionBranch $ Paths_hakyll.version)
223 -- Catch all the things except UserInterrupt
224 failure logger (SomeException e) = case cast e of
225 Just UserInterrupt -> throw UserInterrupt
226 _ -> Logger.error logger (show e) >> return False
228 -- Check scheme-relative links
229 schemeRelative = isPrefixOf "//"
230 urlToCheck = if schemeRelative url then "http:" ++ url else url
231#else
232checkExternalUrl _ = return ()
233#endif
237--------------------------------------------------------------------------------
238-- | Wraps doesFileExist, also checks for index.html
239checkFileExists :: FilePath -> Checker Bool
240checkFileExists filePath = liftIO $ do
241 file <- doesFileExist filePath
242 dir <- doesDirectoryExist filePath
243 case (file, dir) of
244 (True, _) -> return True
245 (_, True) -> doesFileExist $ filePath </> "index.html"
246 _ -> return False
249--------------------------------------------------------------------------------
250stripFragments :: String -> String
251stripFragments = takeWhile (not . flip elem ['?', '#'])