git.iko.soy/hakyll
on c7a1069 help sign in
hakyll/src/Hakyll/Check.hs
253 lines 9.4 kB history raw
1--------------------------------------------------------------------------------
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE OverloadedStrings #-}
4module Hakyll.Check
5 ( Check (..)
6 , check
7 ) where
10--------------------------------------------------------------------------------
11import Control.Monad (forM_)
12import Control.Monad.Reader (ask)
13import Control.Monad.RWS (RWST, runRWST)
14import Control.Monad.Trans (liftIO)
15import Control.Monad.Trans.Resource (runResourceT)
16import Control.Monad.Writer (tell)
17import Data.List (isPrefixOf)
18import Data.Set (Set)
19import qualified Data.Set as S
20import Network.URI (unEscapeString)
21import System.Directory (doesDirectoryExist,
22 doesFileExist)
23import System.Exit (ExitCode (..))
24import System.FilePath (takeDirectory, takeExtension,
25 (</>))
26import qualified Text.HTML.TagSoup as TS
29--------------------------------------------------------------------------------
30#ifdef CHECK_EXTERNAL
31import Control.Exception (AsyncException (..),
32 SomeException (..), handle,
33 throw)
34import Control.Monad.State (get, modify)
35import Data.List (intercalate)
36import Data.Typeable (cast)
37import Data.Version (versionBranch)
38import GHC.Exts (fromString)
39import qualified Network.HTTP.Conduit as Http
40import qualified Network.HTTP.Types as Http
41import qualified Paths_hakyll as Paths_hakyll
42#endif
45--------------------------------------------------------------------------------
46import Hakyll.Core.Configuration
47import Hakyll.Core.Logger (Logger)
48import qualified Hakyll.Core.Logger as Logger
49import Hakyll.Core.Util.File
50import Hakyll.Web.Html
53--------------------------------------------------------------------------------
54data Check = All | InternalLinks
55 deriving (Eq, Ord, Show)
58--------------------------------------------------------------------------------
59check :: Configuration -> Logger -> Check -> IO ExitCode
60check config logger check' = do
61 ((), write) <- runChecker checkDestination config logger check'
62 return $ if checkerFaulty write > 0 then ExitFailure 1 else ExitSuccess
65--------------------------------------------------------------------------------
66data CheckerRead = CheckerRead
67 { checkerConfig :: Configuration
68 , checkerLogger :: Logger
69 , checkerCheck :: Check
70 }
73--------------------------------------------------------------------------------
74data CheckerWrite = CheckerWrite
75 { checkerFaulty :: Int
76 , checkerOk :: Int
77 } deriving (Show)
80--------------------------------------------------------------------------------
81instance Monoid CheckerWrite where
82 mempty = CheckerWrite 0 0
83 mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) =
84 CheckerWrite (f1 + f2) (o1 + o2)
87--------------------------------------------------------------------------------
88type CheckerState = Set String
91--------------------------------------------------------------------------------
92type Checker a = RWST CheckerRead CheckerWrite CheckerState IO a
95--------------------------------------------------------------------------------
96runChecker :: Checker a -> Configuration -> Logger -> Check
97 -> IO (a, CheckerWrite)
98runChecker checker config logger check' = do
99 let read' = CheckerRead
100 { checkerConfig = config
101 , checkerLogger = logger
102 , checkerCheck = check'
103 }
105 (x, _, write) <- runRWST checker read' S.empty
106 Logger.flush logger
107 return (x, write)
110--------------------------------------------------------------------------------
111checkDestination :: Checker ()
112checkDestination = do
113 config <- checkerConfig <$> ask
114 files <- liftIO $ getRecursiveContents
115 (const $ return False) (destinationDirectory config)
117 let htmls =
118 [ destinationDirectory config </> file
119 | file <- files
120 , takeExtension file == ".html"
121 ]
123 forM_ htmls checkFile
126--------------------------------------------------------------------------------
127checkFile :: FilePath -> Checker ()
128checkFile filePath = do
129 logger <- checkerLogger <$> ask
130 contents <- liftIO $ readFile filePath
131 Logger.header logger $ "Checking file " ++ filePath
133 let urls = getUrls $ TS.parseTags contents
134 forM_ urls $ \url -> do
135 Logger.debug logger $ "Checking link " ++ url
136 checkUrl filePath url
139--------------------------------------------------------------------------------
140checkUrl :: FilePath -> String -> Checker ()
141checkUrl filePath url
142 | isExternal url = checkExternalUrl url
143 | hasProtocol url = skip "Unknown protocol, skipping"
144 | otherwise = checkInternalUrl filePath url
145 where
146 validProtoChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "+-."
147 hasProtocol str = case break (== ':') str of
148 (proto, ':' : _) -> all (`elem` validProtoChars) proto
149 _ -> False
152--------------------------------------------------------------------------------
153ok :: String -> Checker ()
154ok _ = tell $ mempty {checkerOk = 1}
157--------------------------------------------------------------------------------
158skip :: String -> Checker ()
159skip reason = do
160 logger <- checkerLogger <$> ask
161 Logger.debug logger $ reason
162 tell $ mempty {checkerOk = 1}
164--------------------------------------------------------------------------------
165faulty :: String -> Checker ()
166faulty url = do
167 logger <- checkerLogger <$> ask
168 Logger.error logger $ "Broken link to " ++ show url
169 tell $ mempty {checkerFaulty = 1}
172--------------------------------------------------------------------------------
173checkInternalUrl :: FilePath -> String -> Checker ()
174checkInternalUrl base url = case url' of
175 "" -> ok url
176 _ -> do
177 config <- checkerConfig <$> ask
178 let dest = destinationDirectory config
179 dir = takeDirectory base
180 filePath
181 | "/" `isPrefixOf` url' = dest ++ url'
182 | otherwise = dir </> url'
184 exists <- checkFileExists filePath
185 if exists then ok url else faulty url
186 where
187 url' = stripFragments $ unEscapeString url
190--------------------------------------------------------------------------------
191checkExternalUrl :: String -> Checker ()
192#ifdef CHECK_EXTERNAL
193checkExternalUrl url = do
194 logger <- checkerLogger <$> ask
195 needsCheck <- (== All) . checkerCheck <$> ask
196 checked <- (url `S.member`) <$> get
198 if not needsCheck || checked
199 then Logger.debug logger "Already checked, skipping"
200 else do
201 isOk <- liftIO $ handle (failure logger) $ do
202 mgr <- Http.newManager Http.tlsManagerSettings
203 runResourceT $ do
204 request <- Http.parseUrl urlToCheck
205 response <- Http.http (settings request) mgr
206 let code = Http.statusCode (Http.responseStatus response)
207 return $ code >= 200 && code < 300
209 modify $ if schemeRelative url
210 then S.insert urlToCheck . S.insert url
211 else S.insert url
212 if isOk then ok url else faulty url
213 where
214 -- Add additional request info
215 settings r = r
216 { Http.method = "HEAD"
217 , Http.redirectCount = 10
218 , Http.requestHeaders = ("User-Agent", ua) : Http.requestHeaders r
219 }
221 -- Nice user agent info
222 ua = fromString $ "hakyll-check/" ++
223 (intercalate "." $ map show $ versionBranch $ Paths_hakyll.version)
225 -- Catch all the things except UserInterrupt
226 failure logger (SomeException e) = case cast e of
227 Just UserInterrupt -> throw UserInterrupt
228 _ -> Logger.error logger (show e) >> return False
230 -- Check scheme-relative links
231 schemeRelative = isPrefixOf "//"
232 urlToCheck = if schemeRelative url then "http:" ++ url else url
233#else
234checkExternalUrl _ = return ()
235#endif
239--------------------------------------------------------------------------------
240-- | Wraps doesFileExist, also checks for index.html
241checkFileExists :: FilePath -> Checker Bool
242checkFileExists filePath = liftIO $ do
243 file <- doesFileExist filePath
244 dir <- doesDirectoryExist filePath
245 case (file, dir) of
246 (True, _) -> return True
247 (_, True) -> doesFileExist $ filePath </> "index.html"
248 _ -> return False
251--------------------------------------------------------------------------------
252stripFragments :: String -> String
253stripFragments = takeWhile (not . flip elem ['?', '#'])