@@ -1,21 +1,29 @@
11--------------------------------------------------------------------------------
2+{-# LANGUAGE OverloadedStrings #-}
23module Hakyll.Check
3− ( runCheck
4+ ( check
45 ) where
56
67
78--------------------------------------------------------------------------------
89import Control.Applicative ((<$>))
9−import Control.Exception (SomeException, handle)
10+import Control.Exception (AsyncException (..),
11+ SomeException (..), handle, throw)
1012import 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)
1216import Control.Monad.Trans (liftIO)
13−import Control.Monad.Writer (WriterT, runWriterT, tell)
17+import Control.Monad.Writer (tell)
1418import Data.List (isPrefixOf)
1519import Data.Monoid (Monoid (..))
20+import Data.Set (Set)
21+import qualified Data.Set as S
22+import Data.Typeable (cast)
1623import qualified Network.HTTP.Conduit as Http
1724import qualified Network.HTTP.Types as Http
1825import System.Directory (doesDirectoryExist, doesFileExist)
26+import System.Exit (ExitCode (..))
1927import System.FilePath (takeDirectory, takeExtension, (</>))
2028import qualified Text.HTML.TagSoup as TS
2129
@@ -28,6 +36,13 @@ import Hakyll.Core.Util.File
2836import Hakyll.Web.Html
2937
3038
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+
3146--------------------------------------------------------------------------------
3247data CheckerRead = CheckerRead
3348 { checkerConfig :: Configuration
@@ -50,22 +65,26 @@ instance Monoid CheckerWrite where
5065
5166
5267--------------------------------------------------------------------------------
53−type Checker a = ReaderT CheckerRead (WriterT CheckerWrite IO) a
68+type CheckerState = Set String
5469
5570
5671--------------------------------------------------------------------------------
57−runCheck :: Configuration -> IO ()
58−runCheck config = do
72+type Checker a = RWST CheckerRead CheckerWrite CheckerState IO a
73+
74+
75+--------------------------------------------------------------------------------
76+runChecker :: Checker a -> Configuration -> IO (a, CheckerWrite)
77+runChecker checker config = do
5978 logger <- Logger.new (verbosity config)
6079 let read' = CheckerRead config logger
61− ((), write) <- runWriterT $ runReaderT check read'
62− Logger.header logger $ show write
80+ (x, _, write) <- runRWST checker read' S.empty
6381 Logger.flush logger
82+ return (x, write)
6483
6584
6685--------------------------------------------------------------------------------
67−check :: Checker ()
68−check = do
86+checkDestination :: Checker ()
87+checkDestination = do
6988 config <- checkerConfig <$> ask
7089 files <- liftIO $ getRecursiveContents (destinationDirectory config)
7190
@@ -83,10 +102,11 @@ checkFile :: FilePath -> Checker ()
83102checkFile filePath = do
84103 logger <- checkerLogger <$> ask
85104 contents <- liftIO $ readFile filePath
86− Logger.header logger $ "Checking " ++ filePath
105+ Logger.header logger $ "Checking file " ++ filePath
87106
88107 let urls = getUrls $ TS.parseTags contents
89− forM_ urls $ \url ->
108+ forM_ urls $ \url -> do
109+ Logger.debug logger $ "Checking link " ++ url
90110 if isExternal url
91111 then checkExternalUrl url
92112 else checkInternalUrl filePath url
@@ -126,24 +146,31 @@ checkInternalUrl base url = case url' of
126146--------------------------------------------------------------------------------
127147checkExternalUrl :: String -> Checker ()
128148checkExternalUrl url = do
129− logger <- checkerLogger <$> ask
130− Logger.message logger $ "Not checking external url " ++ url
131−
132− isOk <- liftIO $ handle failure $ Http.withManager $ \manager -> do
133− request <- Http.parseUrl url
134− response <- Http.http (settings request) manager
135− let code = Http.statusCode (Http.responseStatus response)
136− return $ code >= 200 && code < 300
137−
138− if isOk then ok url else faulty url
149+ logger <- checkerLogger <$> ask
150+ checked <- (url `S.member`) <$> get
151+
152+ if checked
153+ then Logger.debug logger "Already checked, skipping"
154+ else do
155+ isOk <- liftIO $ handle (failure logger) $
156+ Http.withManager $ \mgr -> do
157+ request <- Http.parseUrl url
158+ response <- Http.http (settings request) mgr
159+ let code = Http.statusCode (Http.responseStatus response)
160+ return $ code >= 200 && code < 300
161+
162+ modify $ S.insert url
163+ if isOk then ok url else faulty url
139164 where
140165 settings r = r
141− { Http.redirectCount = 10
142− , Http.responseTimeout = Just 10
166+ { Http.method = "HEAD"
167+ , Http.redirectCount = 10
143168 }
144169
145− failure :: SomeException -> IO Bool
146− failure e = print e >> return False
170+ -- Catch all the things except UserInterrupt
171+ failure logger (SomeException e) = case cast e of
172+ Just UserInterrupt -> throw UserInterrupt
173+ _ -> Logger.error logger (show e) >> return False
147174
148175
149176--------------------------------------------------------------------------------