@@ -8,22 +8,21 @@ module Hakyll.Check
88
99
1010--------------------------------------------------------------------------------
11−import Control.Monad (forM_)
12−import Control.Monad.Reader (ask)
13−import Control.Monad.RWS (RWST, runRWST)
11+import Control.Monad (forM_, foldM)
12+import Control.Monad.Reader (ask, ReaderT, runReaderT)
1413import Control.Monad.Trans (liftIO)
1514import Control.Monad.Trans.Resource (runResourceT)
16−import Control.Monad.Writer (tell)
1715import Data.ByteString.Char8 (unpack)
1816import Data.List (isPrefixOf)
19−import Data.Set (Set)
20−import qualified Data.Set as S
17+import qualified Data.Map.Lazy as Map
2118import Network.URI (unEscapeString)
2219import System.Directory (doesDirectoryExist,
2320 doesFileExist)
2421import System.Exit (ExitCode (..))
2522import System.FilePath (takeDirectory, takeExtension,
2623 (</>))
24+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar,
25+ readMVar)
2726import qualified Text.HTML.TagSoup as TS
2827
2928
@@ -31,7 +30,7 @@ import qualified Text.HTML.TagSoup as TS
3130#ifdef CHECK_EXTERNAL
3231import Control.Exception (SomeAsyncException (..),
3332 SomeException (..), try, throw)
34−import Control.Monad.State (get, modify)
33+import Control.Monad.State (get, modify, StateT, runStateT)
3534import Data.List (intercalate)
3635import Data.Typeable (cast)
3736import Data.Version (versionBranch)
@@ -58,8 +57,17 @@ data Check = All | InternalLinks
5857--------------------------------------------------------------------------------
5958check :: Configuration -> Logger -> Check -> IO ExitCode
6059check config logger check' = do
61− ((), write) <- runChecker checkDestination config logger check'
62− return $ if checkerFaulty write > 0 then ExitFailure 1 else ExitSuccess
60+ ((), state) <- runChecker checkDestination config logger check'
61+ failed <- countFailedLinks state
62+ return $ if failed > 0 then ExitFailure 1 else ExitSuccess
63+
64+
65+--------------------------------------------------------------------------------
66+countFailedLinks :: CheckerState -> IO Int
67+countFailedLinks state = foldM addIfFailure 0 (Map.elems state)
68+ where addIfFailure failures mvar = do
69+ checkerWrite <- readMVar mvar
70+ return $ failures + checkerFaulty checkerWrite
6371
6472
6573--------------------------------------------------------------------------------
@@ -85,26 +93,28 @@ instance Monoid CheckerWrite where
8593
8694
8795--------------------------------------------------------------------------------
88−type CheckerState = Set String
96+type CheckerState = Map.Map URL (MVar CheckerWrite)
8997
9098
9199--------------------------------------------------------------------------------
92−type Checker a = RWST CheckerRead CheckerWrite CheckerState IO a
100+type Checker a = ReaderT CheckerRead (StateT CheckerState IO) a
101+
102+
103+--------------------------------------------------------------------------------
104+type URL = String
93105
94106
95107--------------------------------------------------------------------------------
96108runChecker :: Checker a -> Configuration -> Logger -> Check
97− -> IO (a, CheckerWrite)
109+ -> IO (a, CheckerState)
98110runChecker checker config logger check' = do
99111 let read' = CheckerRead
100112 { checkerConfig = config
101113 , checkerLogger = logger
102114 , checkerCheck = check'
103115 }
104−
105− (x, _, write) <- runRWST checker read' S.empty
106116 Logger.flush logger
107− return (x, write)
117+ runStateT (runReaderT checker read') Map.empty
108118
109119
110120--------------------------------------------------------------------------------
@@ -133,14 +143,31 @@ checkFile filePath = do
133143 let urls = getUrls $ TS.parseTags contents
134144 forM_ urls $ \url -> do
135145 Logger.debug logger $ "Checking link " ++ url
136− checkUrl filePath url
146+ m <- liftIO newEmptyMVar
147+ checkUrlIfNeeded filePath (canonicalizeUrl url) m
148+ where
149+ -- Check scheme-relative links
150+ canonicalizeUrl url = if schemeRelative url then "http:" ++ url else url
151+ schemeRelative = isPrefixOf "//"
152+
153+
154+--------------------------------------------------------------------------------
155+checkUrlIfNeeded :: FilePath -> URL -> MVar CheckerWrite -> Checker ()
156+checkUrlIfNeeded filepath url m = do
157+ logger <- checkerLogger <$> ask
158+ needsCheck <- (== All) . checkerCheck <$> ask
159+ checked <- (url `Map.member`) <$> get
160+ if not needsCheck || checked
161+ then Logger.debug logger "Already checked, skipping"
162+ else do modify $ Map.insert url m
163+ checkUrl filepath url
137164
138165
139166--------------------------------------------------------------------------------
140−checkUrl :: FilePath -> String -> Checker ()
167+checkUrl :: FilePath -> URL -> Checker ()
141168checkUrl filePath url
142169 | isExternal url = checkExternalUrl url
143− | hasProtocol url = skip "Unknown protocol, skipping"
170+ | hasProtocol url = skip url $ Just "Unknown protocol, skipping"
144171 | otherwise = checkInternalUrl filePath url
145172 where
146173 validProtoChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "+-."
@@ -150,30 +177,45 @@ checkUrl filePath url
150177
151178
152179--------------------------------------------------------------------------------
153−ok :: String -> Checker ()
154−ok _ = tell $ mempty {checkerOk = 1}
180+ok :: URL -> Checker ()
181+ok url = putCheckResult url mempty {checkerOk = 1}
155182
156183
157184--------------------------------------------------------------------------------
158−skip :: String -> Checker ()
159−skip reason = do
185+skip :: URL -> Maybe String -> Checker ()
186+skip url maybeReason = do
160187 logger <- checkerLogger <$> ask
161− Logger.debug logger $ reason
162− tell $ mempty {checkerOk = 1}
188+ case maybeReason of
189+ Nothing -> return ()
190+ Just reason -> Logger.debug logger reason
191+ putCheckResult url mempty {checkerOk = 1}
192+
163193
164194--------------------------------------------------------------------------------
165−faulty :: String -> Maybe String -> Checker ()
195+faulty :: URL -> Maybe String -> Checker ()
166196faulty url reason = do
167197 logger <- checkerLogger <$> ask
168198 Logger.error logger $ "Broken link to " ++ show url ++ explanation
169− tell $ mempty {checkerFaulty = 1}
199+ putCheckResult url mempty {checkerFaulty = 1}
170200 where
171201 formatExplanation = (" (" ++) . (++ ")")
172202 explanation = maybe "" formatExplanation reason
173203
174204
175205--------------------------------------------------------------------------------
176−checkInternalUrl :: FilePath -> String -> Checker ()
206+putCheckResult :: URL -> CheckerWrite -> Checker ()
207+putCheckResult url result = do
208+ state <- get
209+ let maybeMVar = Map.lookup url state
210+ case maybeMVar of
211+ Just m -> liftIO $ putMVar m result
212+ Nothing -> do
213+ logger <- checkerLogger <$> ask
214+ Logger.debug logger "Failed to find existing entry for checked URL"
215+
216+
217+--------------------------------------------------------------------------------
218+checkInternalUrl :: FilePath -> URL -> Checker ()
177219checkInternalUrl base url = case url' of
178220 "" -> ok url
179221 _ -> do
@@ -191,58 +233,47 @@ checkInternalUrl base url = case url' of
191233
192234
193235--------------------------------------------------------------------------------
194−checkExternalUrl :: String -> Checker ()
236+checkExternalUrl :: URL -> Checker ()
195237#ifdef CHECK_EXTERNAL
196238checkExternalUrl url = do
197− logger <- checkerLogger <$> ask
198− needsCheck <- (== All) . checkerCheck <$> ask
199− checked <- (url `S.member`) <$> get
200−
201− if not needsCheck || checked
202− then Logger.debug logger "Already checked, skipping"
203− else do
204− result <- liftIO $ try $ do
205− mgr <- Http.newManager Http.tlsManagerSettings
206− runResourceT $ do
207− request <- Http.parseRequest urlToCheck
208− response <- Http.http (settings request) mgr
209− let code = Http.statusCode (Http.responseStatus response)
210− return $ code >= 200 && code < 300
211−
212− modify $ if schemeRelative url
213− then S.insert urlToCheck . S.insert url
214− else S.insert url
215− case result of
216− Left (SomeException e) ->
217− case (cast e :: Maybe SomeAsyncException) of
218− Just ae -> throw ae
219− _ -> faulty url (Just $ showException e)
220− Right _ -> ok url
221− where
222− -- Add additional request info
223− settings r = r
224− { Http.method = "HEAD"
225− , Http.redirectCount = 10
226− , Http.requestHeaders = ("User-Agent", ua) : Http.requestHeaders r
227− }
228−
229− -- Nice user agent info
230− ua = fromString $ "hakyll-check/" ++
231− (intercalate "." $ map show $ versionBranch $ Paths_hakyll.version)
232−
233− -- Check scheme-relative links
234− schemeRelative = isPrefixOf "//"
235− urlToCheck = if schemeRelative url then "http:" ++ url else url
236−
237− -- Convert exception to a concise form
238− showException e = case cast e of
239− Just (Http.HttpExceptionRequest _ e') -> show e'
240− _ -> head $ words $ show e
239+ result <- requestExternalUrl url
240+ case result of
241+ Left (SomeException e) ->
242+ case (cast e :: Maybe SomeAsyncException) of
243+ Just ae -> throw ae
244+ _ -> faulty url (Just $ showException e)
245+ Right _ -> ok url
246+ where
247+ -- Convert exception to a concise form
248+ showException e = case cast e of
249+ Just (Http.HttpExceptionRequest _ e') -> show e'
250+ _ -> head $ words $ show e
241251#else
242−checkExternalUrl _ = return ()
252+checkExternalUrl url = skip url Nothing
243253#endif
244254
245255
256+--------------------------------------------------------------------------------
257+requestExternalUrl :: URL -> Checker (Either SomeException Bool)
258+requestExternalUrl url = liftIO $ try $ do
259+ mgr <- Http.newManager Http.tlsManagerSettings
260+ runResourceT $ do
261+ request <- Http.parseRequest url
262+ response <- Http.http (settings request) mgr
263+ let code = Http.statusCode (Http.responseStatus response)
264+ return $ code >= 200 && code < 300
265+ where
266+ -- Add additional request info
267+ settings r = r
268+ { Http.method = "HEAD"
269+ , Http.redirectCount = 10
270+ , Http.requestHeaders = ("User-Agent", ua) : Http.requestHeaders r
271+ }
272+
273+ -- Nice user agent info
274+ ua = fromString $ "hakyll-check/" ++
275+ (intercalate "." $ map show $ versionBranch Paths_hakyll.version)
276+
246277
247278--------------------------------------------------------------------------------
248279-- | Wraps doesFileExist, also checks for index.html