506a67c · hakyll · git.iko.soy

git.iko.soy/hakyll

on master help sign in

Refactor & fixes for external link checker

506a67cJasper Van der Jeugt14 years ago

hakyll.cabal+5−2

compare with master

unifiedsplit

@@ -96,6 +96,8 @@ Library

96 deepseq >= 1.3 && < 1.4,

97 directory >= 1.0 && < 1.3,

98 filepath >= 1.0 && < 1.4,

99+ http-conduit >= 1.8 && < 1.9,

100+ http-types >= 0.7 && < 0.8,

99 lrucache >= 1.1.1 && < 1.2,

101 lrucache >= 1.1.1 && < 1.2,

100 mtl >= 1 && < 2.2,

102 mtl >= 1 && < 2.2,

101 old-locale >= 1.0 && < 1.1,

103 old-locale >= 1.0 && < 1.1,

@@ -197,6 +199,8 @@ Test-suite hakyll-tests

197 deepseq >= 1.3 && < 1.4,

199 deepseq >= 1.3 && < 1.4,

198 directory >= 1.0 && < 1.3,

200 directory >= 1.0 && < 1.3,

199 filepath >= 1.0 && < 1.4,

201 filepath >= 1.0 && < 1.4,

202+ http-conduit >= 1.8 && < 1.9,

203+ http-types >= 0.7 && < 0.8,

200 lrucache >= 1.1.1 && < 1.2,

204 lrucache >= 1.1.1 && < 1.2,

201 mtl >= 1 && < 2.2,

205 mtl >= 1 && < 2.2,

202 old-locale >= 1.0 && < 1.1,

206 old-locale >= 1.0 && < 1.1,

@@ -208,8 +212,7 @@ Test-suite hakyll-tests

208 regex-tdfa >= 1.1 && < 1.2,

212 regex-tdfa >= 1.1 && < 1.2,

209 tagsoup >= 0.12.6 && < 0.13,

213 tagsoup >= 0.12.6 && < 0.13,

210 text >= 0.11 && < 1.12,

214 text >= 0.11 && < 1.12,

211− time >= 1.1 && < 1.5,

215+ time >= 1.1 && < 1.5

212− unix >= 2.4 && < 2.7

213

216

214 Other-modules:

217 Other-modules:

215 Hakyll.Core.Dependencies.Tests

218 Hakyll.Core.Dependencies.Tests

src/Hakyll/Check.hs+54−27

@@ -1,21 +1,29 @@

1--------------------------------------------------------------------------------

2+{-# LANGUAGE OverloadedStrings #-}

2module Hakyll.Check

3module Hakyll.Check

3− ( runCheck

4+ ( check

4 ) where

5 ) where

7--------------------------------------------------------------------------------

8--------------------------------------------------------------------------------

8import Control.Applicative ((<$>))

9import Control.Applicative ((<$>))

10+import Control.Exception (AsyncException (..),

9−import Control.Exception (SomeException, handle)

11+ SomeException (..), handle, throw)

10import Control.Monad (forM_)

12import Control.Monad (forM_)

11−import Control.Monad.Reader (ReaderT, ask, runReaderT)

13+import Control.Monad.Reader (ask)

14+import Control.Monad.RWS (RWST, runRWST)

15+import Control.Monad.State (get, modify)

12import Control.Monad.Trans (liftIO)

16import Control.Monad.Trans (liftIO)

13−import Control.Monad.Writer (WriterT, runWriterT, tell)

17+import Control.Monad.Writer (tell)

14import Data.List (isPrefixOf)

18import Data.List (isPrefixOf)

15import Data.Monoid (Monoid (..))

19import Data.Monoid (Monoid (..))

20+import Data.Set (Set)

21+import qualified Data.Set as S

22+import Data.Typeable (cast)

16import qualified Network.HTTP.Conduit as Http

23import qualified Network.HTTP.Conduit as Http

17import qualified Network.HTTP.Types as Http

24import qualified Network.HTTP.Types as Http

18import System.Directory (doesDirectoryExist, doesFileExist)

25import System.Directory (doesDirectoryExist, doesFileExist)

26+import System.Exit (ExitCode (..))

19import System.FilePath (takeDirectory, takeExtension, (</>))

27import System.FilePath (takeDirectory, takeExtension, (</>))

20import qualified Text.HTML.TagSoup as TS

28import qualified Text.HTML.TagSoup as TS

@@ -28,6 +36,13 @@ import Hakyll.Core.Util.File

28import Hakyll.Web.Html

36import Hakyll.Web.Html

39+--------------------------------------------------------------------------------

40+check :: Configuration -> IO ExitCode

41+check config = do

42+ ((), write) <- runChecker checkDestination config

43+ return $ if checkerFaulty write >= 0 then ExitFailure 1 else ExitSuccess

44+

45+

31--------------------------------------------------------------------------------

46--------------------------------------------------------------------------------

32data CheckerRead = CheckerRead

47data CheckerRead = CheckerRead

33 { checkerConfig :: Configuration

48 { checkerConfig :: Configuration

@@ -50,22 +65,26 @@ instance Monoid CheckerWrite where

52--------------------------------------------------------------------------------

67--------------------------------------------------------------------------------

53−type Checker a = ReaderT CheckerRead (WriterT CheckerWrite IO) a

68+type CheckerState = Set String

56--------------------------------------------------------------------------------

71--------------------------------------------------------------------------------

72+type Checker a = RWST CheckerRead CheckerWrite CheckerState IO a

73+

74+

75+--------------------------------------------------------------------------------

57−runCheck :: Configuration -> IO ()

76+runChecker :: Checker a -> Configuration -> IO (a, CheckerWrite)

58−runCheck config = do

77+runChecker checker config = do

59 logger <- Logger.new (verbosity config)

78 logger <- Logger.new (verbosity config)

60 let read' = CheckerRead config logger

79 let read' = CheckerRead config logger

61− ((), write) <- runWriterT $ runReaderT check read'

80+ (x, _, write) <- runRWST checker read' S.empty

62− Logger.header logger $ show write

63 Logger.flush logger

81 Logger.flush logger

82+ return (x, write)

66--------------------------------------------------------------------------------

85--------------------------------------------------------------------------------

67−check :: Checker ()

86+checkDestination :: Checker ()

68−check = do

87+checkDestination = do

69 config <- checkerConfig <$> ask

88 config <- checkerConfig <$> ask

70 files <- liftIO $ getRecursiveContents (destinationDirectory config)

89 files <- liftIO $ getRecursiveContents (destinationDirectory config)

@@ -83,10 +102,11 @@ checkFile :: FilePath -> Checker ()

83checkFile filePath = do

102checkFile filePath = do

84 logger <- checkerLogger <$> ask

103 logger <- checkerLogger <$> ask

85 contents <- liftIO $ readFile filePath

104 contents <- liftIO $ readFile filePath

86− Logger.header logger $ "Checking " ++ filePath

105+ Logger.header logger $ "Checking file " ++ filePath

106

88 let urls = getUrls $ TS.parseTags contents

107 let urls = getUrls $ TS.parseTags contents

89− forM_ urls $ \url ->

108+ forM_ urls $ \url -> do

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

90 if isExternal url

110 if isExternal url

91 then checkExternalUrl url

111 then checkExternalUrl url

92 else checkInternalUrl filePath url

112 else checkInternalUrl filePath url

@@ -126,24 +146,31 @@ checkInternalUrl base url = case url' of

126--------------------------------------------------------------------------------

146--------------------------------------------------------------------------------

127checkExternalUrl :: String -> Checker ()

147checkExternalUrl :: String -> Checker ()

128checkExternalUrl url = do

148checkExternalUrl url = do

129− logger <- checkerLogger <$> ask

149+ logger <- checkerLogger <$> ask

130− Logger.message logger $ "Not checking external url " ++ url

150+ checked <- (url `S.member`) <$> get

131−

151+

152+ if checked

153+ then Logger.debug logger "Already checked, skipping"

154+ else do

132− isOk <- liftIO $ handle failure $ Http.withManager $ \manager -> do

155+ isOk <- liftIO $ handle (failure logger) $

156+ Http.withManager $ \mgr -> do

133− request <- Http.parseUrl url

157+ request <- Http.parseUrl url

134− response <- Http.http (settings request) manager

158+ response <- Http.http (settings request) mgr

135− let code = Http.statusCode (Http.responseStatus response)

159+ let code = Http.statusCode (Http.responseStatus response)

136− return $ code >= 200 && code < 300

160+ return $ code >= 200 && code < 300

137−

161+

162+ modify $ S.insert url

138− if isOk then ok url else faulty url

163+ if isOk then ok url else faulty url

139 where

164 where

140 settings r = r

165 settings r = r

141− { Http.redirectCount = 10

166+ { Http.method = "HEAD"

142− , Http.responseTimeout = Just 10

167+ , Http.redirectCount = 10

143 }

168 }

144

169

170+ -- Catch all the things except UserInterrupt

145− failure :: SomeException -> IO Bool

171+ failure logger (SomeException e) = case cast e of

172+ Just UserInterrupt -> throw UserInterrupt

146− failure e = print e >> return False

173+ _ -> Logger.error logger (show e) >> return False

147

174

148

175

149--------------------------------------------------------------------------------

176--------------------------------------------------------------------------------

src/Hakyll/Core/Runtime.hs+1

@@ -40,6 +40,7 @@ import Hakyll.Core.Writable

42--------------------------------------------------------------------------------

43+-- | TODO Make this return exit code?

43run :: Configuration -> Rules a -> IO RuleSet

44run :: Configuration -> Rules a -> IO RuleSet

44run config rules = do

45run config rules = do

45 -- Initialization

46 -- Initialization

src/Hakyll/Main.hs+4−3

@@ -12,11 +12,12 @@ import Control.Monad (when)

12import System.Directory (doesDirectoryExist,

13 removeDirectoryRecursive)

14import System.Environment (getArgs, getProgName)

15+import System.Exit (exitWith)

15import System.Process (system)

16import System.Process (system)

18--------------------------------------------------------------------------------

19--------------------------------------------------------------------------------

19−import Hakyll.Check

20+import qualified Hakyll.Check as Check

20import Hakyll.Core.Configuration

21import Hakyll.Core.Configuration

21import Hakyll.Core.Rules

22import Hakyll.Core.Rules

22import Hakyll.Core.Runtime

23import Hakyll.Core.Runtime

@@ -69,9 +70,9 @@ build conf rules = do

71--------------------------------------------------------------------------------

72--------------------------------------------------------------------------------

72−-- | Run the checker

73+-- | Run the checker and exit

73check :: Configuration -> IO ()

74check :: Configuration -> IO ()

74−check = runCheck

75+check config = Check.check config >>= exitWith

77--------------------------------------------------------------------------------

78--------------------------------------------------------------------------------