164a7dc · hakyll · git.iko.soy

14import Control.Monad.Trans (liftIO)

15import Control.Monad.Trans.Resource (runResourceT)

16import Control.Monad.Writer (tell)

17+import Data.ByteString.Char8 (unpack)

17import Data.List (isPrefixOf)

18import Data.List (isPrefixOf)

18import Data.Set (Set)

19import Data.Set (Set)

19import qualified Data.Set as S

20import qualified Data.Set as S

28

29

29--------------------------------------------------------------------------------

30--------------------------------------------------------------------------------

30#ifdef CHECK_EXTERNAL

31#ifdef CHECK_EXTERNAL

31−import Control.Exception (AsyncException (..),

32+import Control.Exception (SomeAsyncException (..),

32− SomeException (..), handle,

33+ SomeException (..), try, throw)

33− throw)

34import Control.Monad.State (get, modify)

35import Data.List (intercalate)

36import Data.Typeable (cast)

162 tell $ mempty {checkerOk = 1}

163

164--------------------------------------------------------------------------------

165−faulty :: String -> Checker ()

165+faulty :: String -> Maybe String -> Checker ()

166−faulty url = do

166+faulty url reason = do

167 logger <- checkerLogger <$> ask

168− Logger.error logger $ "Broken link to " ++ show url

168+ Logger.error logger $ "Broken link to " ++ show url ++ explanation

169 tell $ mempty {checkerFaulty = 1}

170+ where

171+ formatExplanation = (" (" ++) . (++ ")")

172+ explanation = maybe "" formatExplanation reason

170

173

171

174

172--------------------------------------------------------------------------------

175--------------------------------------------------------------------------------

182 | otherwise = dir </> url'

185 | otherwise = dir </> url'

183

186

184 exists <- checkFileExists filePath

187 exists <- checkFileExists filePath

185− if exists then ok url else faulty url

188+ if exists then ok url else faulty url Nothing

186 where

189 where

187 url' = stripFragments $ unEscapeString url

190 url' = stripFragments $ unEscapeString url

188

191

198 if not needsCheck || checked

201 if not needsCheck || checked

199 then Logger.debug logger "Already checked, skipping"

202 then Logger.debug logger "Already checked, skipping"

200 else do

203 else do

201− isOk <- liftIO $ handle (failure logger) $ do

204+ result <- liftIO $ try $ do

202 mgr <- Http.newManager Http.tlsManagerSettings

205 mgr <- Http.newManager Http.tlsManagerSettings

203 runResourceT $ do

206 runResourceT $ do

204 request <- Http.parseUrl urlToCheck

207 request <- Http.parseUrl urlToCheck

209 modify $ if schemeRelative url

212 modify $ if schemeRelative url

210 then S.insert urlToCheck . S.insert url

213 then S.insert urlToCheck . S.insert url

211 else S.insert url

214 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

213 where

221 where

214 -- Add additional request info

222 -- Add additional request info

215 settings r = r

223 settings r = r

222 ua = fromString $ "hakyll-check/" ++

230 ua = fromString $ "hakyll-check/" ++

223 (intercalate "." $ map show $ versionBranch $ Paths_hakyll.version)

231 (intercalate "." $ map show $ versionBranch $ Paths_hakyll.version)

224

232

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−

230 -- Check scheme-relative links

233 -- Check scheme-relative links

231 schemeRelative = isPrefixOf "//"

234 schemeRelative = isPrefixOf "//"

232 urlToCheck = if schemeRelative url then "http:" ++ url else url

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.StatusCodeException (Http.Status code msg) _ _) ->

240+ show code ++ " " ++ unpack msg

241+ _ -> head $ words $ show e

233#else

242#else

234checkExternalUrl _ = return ()

243checkExternalUrl _ = return ()

235#endif

244#endif