@@ -14,6 +14,7 @@ import Control.Monad.RWS (RWST, runRWST)
1414import Control.Monad.Trans (liftIO)
1515import Control.Monad.Trans.Resource (runResourceT)
1616import Control.Monad.Writer (tell)
17+import Data.ByteString.Char8 (unpack)
1718import Data.List (isPrefixOf)
1819import Data.Set (Set)
1920import qualified Data.Set as S
@@ -28,9 +29,8 @@ import qualified Text.HTML.TagSoup as TS
2829
2930--------------------------------------------------------------------------------
3031#ifdef CHECK_EXTERNAL
31−import Control.Exception (AsyncException (..),
32− SomeException (..), handle,
33− throw)
32+import Control.Exception (SomeAsyncException (..),
33+ SomeException (..), try, throw)
3434import Control.Monad.State (get, modify)
3535import Data.List (intercalate)
3636import Data.Typeable (cast)
@@ -162,11 +162,14 @@ skip reason = do
162162 tell $ mempty {checkerOk = 1}
163163
164164--------------------------------------------------------------------------------
165−faulty :: String -> Checker ()
166−faulty url = do
165+faulty :: String -> Maybe String -> Checker ()
166+faulty url reason = do
167167 logger <- checkerLogger <$> ask
168− Logger.error logger $ "Broken link to " ++ show url
168+ Logger.error logger $ "Broken link to " ++ show url ++ explanation
169169 tell $ mempty {checkerFaulty = 1}
170+ where
171+ formatExplanation = (" (" ++) . (++ ")")
172+ explanation = maybe "" formatExplanation reason
170173
171174
172175--------------------------------------------------------------------------------
@@ -182,7 +185,7 @@ checkInternalUrl base url = case url' of
182185 | otherwise = dir </> url'
183186
184187 exists <- checkFileExists filePath
185− if exists then ok url else faulty url
188+ if exists then ok url else faulty url Nothing
186189 where
187190 url' = stripFragments $ unEscapeString url
188191
@@ -198,7 +201,7 @@ checkExternalUrl url = do
198201 if not needsCheck || checked
199202 then Logger.debug logger "Already checked, skipping"
200203 else do
201− isOk <- liftIO $ handle (failure logger) $ do
204+ result <- liftIO $ try $ do
202205 mgr <- Http.newManager Http.tlsManagerSettings
203206 runResourceT $ do
204207 request <- Http.parseUrl urlToCheck
@@ -209,7 +212,12 @@ checkExternalUrl url = do
209212 modify $ if schemeRelative url
210213 then S.insert urlToCheck . S.insert url
211214 else S.insert url
212− if isOk then ok url else faulty 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
213221 where
214222 -- Add additional request info
215223 settings r = r
@@ -222,14 +230,15 @@ checkExternalUrl url = do
222230 ua = fromString $ "hakyll-check/" ++
223231 (intercalate "." $ map show $ versionBranch $ Paths_hakyll.version)
224232
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
229−
230233 -- Check scheme-relative links
231234 schemeRelative = isPrefixOf "//"
232235 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.StatusCodeException (Http.Status code msg) _ _) ->
240+ show code ++ " " ++ unpack msg
241+ _ -> head $ words $ show e
233242#else
234243checkExternalUrl _ = return ()
235244#endif