340b86d · hakyll · git.iko.soy

8

9

10--------------------------------------------------------------------------------

11−import Control.Monad (forM_)

11+import Control.Monad (forM_, foldM)

12−import Control.Monad.Reader (ask)

12+import Control.Monad.Reader (ask, ReaderT, runReaderT)

13−import Control.Monad.RWS (RWST, runRWST)

14import Control.Monad.Trans (liftIO)

13import Control.Monad.Trans (liftIO)

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

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

16−import Control.Monad.Writer (tell)

17import Data.ByteString.Char8 (unpack)

15import Data.ByteString.Char8 (unpack)

18import Data.List (isPrefixOf)

16import Data.List (isPrefixOf)

19−import Data.Set (Set)

20−import qualified Data.Set as S

17+import qualified Data.Map.Lazy as Map

21import Network.URI (unEscapeString)

18import Network.URI (unEscapeString)

22import System.Directory (doesDirectoryExist,

19import System.Directory (doesDirectoryExist,

23 doesFileExist)

20 doesFileExist)

24import System.Exit (ExitCode (..))

21import System.Exit (ExitCode (..))

25import System.FilePath (takeDirectory, takeExtension,

22import System.FilePath (takeDirectory, takeExtension,

26 (</>))

23 (</>))

24+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar,

25+ readMVar)

27import qualified Text.HTML.TagSoup as TS

26import qualified Text.HTML.TagSoup as TS

28

27

29

28

31#ifdef CHECK_EXTERNAL

30#ifdef CHECK_EXTERNAL

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

31import Control.Exception (SomeAsyncException (..),

33 SomeException (..), try, throw)

32 SomeException (..), try, throw)

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

33+import Control.Monad.State (get, modify, StateT, runStateT)

35import Data.List (intercalate)

34import Data.List (intercalate)

36import Data.Typeable (cast)

35import Data.Typeable (cast)

37import Data.Version (versionBranch)

36import Data.Version (versionBranch)

58--------------------------------------------------------------------------------

57--------------------------------------------------------------------------------

59check :: Configuration -> Logger -> Check -> IO ExitCode

58check :: Configuration -> Logger -> Check -> IO ExitCode

60check config logger check' = do

59check config logger check' = do

61− ((), write) <- runChecker checkDestination config logger check'

60+ ((), state) <- runChecker checkDestination config logger check'

61+ failed <- countFailedLinks state

62− return $ if checkerFaulty write > 0 then ExitFailure 1 else ExitSuccess

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

63

71

64

72

65--------------------------------------------------------------------------------

73--------------------------------------------------------------------------------

85

93

86

94

87--------------------------------------------------------------------------------

95--------------------------------------------------------------------------------

88−type CheckerState = Set String

96+type CheckerState = Map.Map URL (MVar CheckerWrite)

89

97

90

98

91--------------------------------------------------------------------------------

99--------------------------------------------------------------------------------

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

93

105

94

106

95--------------------------------------------------------------------------------

107--------------------------------------------------------------------------------

96runChecker :: Checker a -> Configuration -> Logger -> Check

108runChecker :: Checker a -> Configuration -> Logger -> Check

97− -> IO (a, CheckerWrite)

109+ -> IO (a, CheckerState)

98runChecker checker config logger check' = do

110runChecker checker config logger check' = do

99 let read' = CheckerRead

111 let read' = CheckerRead

100 { checkerConfig = config

112 { checkerConfig = config

101 , checkerLogger = logger

113 , checkerLogger = logger

102 , checkerCheck = check'

114 , checkerCheck = check'

103 }

115 }

104−

105− (x, _, write) <- runRWST checker read' S.empty

106 Logger.flush logger

116 Logger.flush logger

107− return (x, write)

117+ runStateT (runReaderT checker read') Map.empty

108

118

109

119

110--------------------------------------------------------------------------------

120--------------------------------------------------------------------------------

133 let urls = getUrls $ TS.parseTags contents

143 let urls = getUrls $ TS.parseTags contents

134 forM_ urls $ \url -> do

144 forM_ urls $ \url -> do

135 Logger.debug logger $ "Checking link " ++ url

145 Logger.debug logger $ "Checking link " ++ 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

136− checkUrl filePath url

163+ checkUrl filepath url

137

164

138

165

139--------------------------------------------------------------------------------

166--------------------------------------------------------------------------------

140−checkUrl :: FilePath -> String -> Checker ()

167+checkUrl :: FilePath -> URL -> Checker ()

141checkUrl filePath url

168checkUrl filePath url

142 | isExternal url = checkExternalUrl url

169 | isExternal url = checkExternalUrl url

143− | hasProtocol url = skip "Unknown protocol, skipping"

170+ | hasProtocol url = skip url $ Just "Unknown protocol, skipping"

144 | otherwise = checkInternalUrl filePath url

171 | otherwise = checkInternalUrl filePath url

145 where

172 where

146 validProtoChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "+-."

173 validProtoChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "+-."

150

177

151

178

152--------------------------------------------------------------------------------

179--------------------------------------------------------------------------------

153−ok :: String -> Checker ()

180+ok :: URL -> Checker ()

154−ok _ = tell $ mempty {checkerOk = 1}

181+ok url = putCheckResult url mempty {checkerOk = 1}

155

182

156

183

157--------------------------------------------------------------------------------

184--------------------------------------------------------------------------------

158−skip :: String -> Checker ()

185+skip :: URL -> Maybe String -> Checker ()

159−skip reason = do

186+skip url maybeReason = do

160 logger <- checkerLogger <$> ask

187 logger <- checkerLogger <$> ask

188+ case maybeReason of

189+ Nothing -> return ()

161− Logger.debug logger $ reason

190+ Just reason -> Logger.debug logger reason

162− tell $ mempty {checkerOk = 1}

191+ putCheckResult url mempty {checkerOk = 1}

192+

163

193

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

194--------------------------------------------------------------------------------

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

195+faulty :: URL -> Maybe String -> Checker ()

166faulty url reason = do

196faulty url reason = do

167 logger <- checkerLogger <$> ask

197 logger <- checkerLogger <$> ask

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

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

169− tell $ mempty {checkerFaulty = 1}

199+ putCheckResult url mempty {checkerFaulty = 1}

170 where

200 where

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

201 formatExplanation = (" (" ++) . (++ ")")

172 explanation = maybe "" formatExplanation reason

202 explanation = maybe "" formatExplanation reason

173

203

174

204

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

205--------------------------------------------------------------------------------

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+--------------------------------------------------------------------------------

176−checkInternalUrl :: FilePath -> String -> Checker ()

218+checkInternalUrl :: FilePath -> URL -> Checker ()

177checkInternalUrl base url = case url' of

219checkInternalUrl base url = case url' of

178 "" -> ok url

220 "" -> ok url

179 _ -> do

221 _ -> do

191

233

192

234

193--------------------------------------------------------------------------------

235--------------------------------------------------------------------------------

194−checkExternalUrl :: String -> Checker ()

236+checkExternalUrl :: URL -> Checker ()

195#ifdef CHECK_EXTERNAL

237#ifdef CHECK_EXTERNAL

196checkExternalUrl url = do

238checkExternalUrl url = do

197− logger <- checkerLogger <$> ask

239+ result <- requestExternalUrl url

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

240+ case result of

216− Left (SomeException e) ->

241+ Left (SomeException e) ->

217− case (cast e :: Maybe SomeAsyncException) of

242+ case (cast e :: Maybe SomeAsyncException) of

218− Just ae -> throw ae

243+ Just ae -> throw ae

219− _ -> faulty url (Just $ showException e)

244+ _ -> faulty url (Just $ showException e)

220− Right _ -> ok url

245+ Right _ -> ok url

221− where

246+ 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

247+ -- Convert exception to a concise form

238− showException e = case cast e of

248+ showException e = case cast e of

239− Just (Http.HttpExceptionRequest _ e') -> show e'

249+ Just (Http.HttpExceptionRequest _ e') -> show e'

240− _ -> head $ words $ show e

250+ _ -> head $ words $ show e

241#else

251#else

242−checkExternalUrl _ = return ()

252+checkExternalUrl url = skip url Nothing

243#endif

253#endif

244

254

245

255

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+

246

277

247--------------------------------------------------------------------------------

278--------------------------------------------------------------------------------

248-- | Wraps doesFileExist, also checks for index.html

279-- | Wraps doesFileExist, also checks for index.html