@@ -6,12 +6,15 @@ module Hakyll.Check
66
77--------------------------------------------------------------------------------
88import Control.Applicative ((<$>))
9+import Control.Exception (SomeException, handle)
910import Control.Monad (forM_)
1011import Control.Monad.Reader (ReaderT, ask, runReaderT)
1112import Control.Monad.Trans (liftIO)
1213import Control.Monad.Writer (WriterT, runWriterT, tell)
1314import Data.List (isPrefixOf)
1415import Data.Monoid (Monoid (..))
16+import qualified Network.HTTP.Conduit as Http
17+import qualified Network.HTTP.Types as Http
1518import System.Directory (doesDirectoryExist, doesFileExist)
1619import System.FilePath (takeDirectory, takeExtension, (</>))
1720import qualified Text.HTML.TagSoup as TS
@@ -89,14 +92,25 @@ checkFile filePath = do
8992 else checkInternalUrl filePath url
9093
9194
95+--------------------------------------------------------------------------------
96+ok :: String -> Checker ()
97+ok _ = tell $ mempty {checkerOk = 1}
98+
99+
100+--------------------------------------------------------------------------------
101+faulty :: String -> Checker ()
102+faulty url = do
103+ logger <- checkerLogger <$> ask
104+ Logger.error logger $ "Broken link to " ++ show url
105+ tell $ mempty {checkerFaulty = 1}
106+
107+
92108--------------------------------------------------------------------------------
93109checkInternalUrl :: FilePath -> String -> Checker ()
94110checkInternalUrl base url = case url' of
95− "" -> tell $ mempty {checkerOk = 1}
111+ "" -> ok url
96112 _ -> do
97− logger <- checkerLogger <$> ask
98113 config <- checkerConfig <$> ask
99−
100114 let dest = destinationDirectory config
101115 dir = takeDirectory base
102116 filePath
@@ -104,11 +118,7 @@ checkInternalUrl base url = case url' of
104118 | otherwise = dir </> url'
105119
106120 exists <- checkFileExists filePath
107− if exists
108− then tell $ mempty {checkerOk = 1}
109− else do
110− tell $ mempty {checkerFaulty = 1}
111− Logger.error logger $ base ++ ": broken link to " ++ show url
121+ if exists then ok url else faulty url
112122 where
113123 url' = stripFragments url
114124
@@ -118,7 +128,22 @@ checkExternalUrl :: String -> Checker ()
118128checkExternalUrl url = do
119129 logger <- checkerLogger <$> ask
120130 Logger.message logger $ "Not checking external url " ++ url
121− -- TODO: use http-conduit and a cache?
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
139+ where
140+ settings r = r
141+ { Http.redirectCount = 10
142+ , Http.responseTimeout = Just 10
143+ }
144+
145+ failure :: SomeException -> IO Bool
146+ failure e = print e >> return False
122147
123148
124149--------------------------------------------------------------------------------