git.iko.soy/hakyll
on master help sign in
Draft external URL checker
58e0d3fJasper Van der Jeugt
src/Hakyll/Check.hs+34−9
compare with master
unifiedsplit
@@ -6,12 +6,15 @@ module Hakyll.Check
6
6
7--------------------------------------------------------------------------------
7--------------------------------------------------------------------------------
8import Control.Applicative ((<$>))
8import Control.Applicative ((<$>))
9+import Control.Exception (SomeException, handle)
9import Control.Monad (forM_)
10import Control.Monad (forM_)
10import Control.Monad.Reader (ReaderT, ask, runReaderT)
11import Control.Monad.Reader (ReaderT, ask, runReaderT)
11import Control.Monad.Trans (liftIO)
12import Control.Monad.Trans (liftIO)
12import Control.Monad.Writer (WriterT, runWriterT, tell)
13import Control.Monad.Writer (WriterT, runWriterT, tell)
13import Data.List (isPrefixOf)
14import Data.List (isPrefixOf)
14import Data.Monoid (Monoid (..))
15import Data.Monoid (Monoid (..))
16+import qualified Network.HTTP.Conduit as Http
17+import qualified Network.HTTP.Types as Http
15import System.Directory (doesDirectoryExist, doesFileExist)
18import System.Directory (doesDirectoryExist, doesFileExist)
16import System.FilePath (takeDirectory, takeExtension, (</>))
19import System.FilePath (takeDirectory, takeExtension, (</>))
17import qualified Text.HTML.TagSoup as TS
20import qualified Text.HTML.TagSoup as TS
@@ -89,14 +92,25 @@ checkFile filePath = do
89 else checkInternalUrl filePath url
92 else checkInternalUrl filePath url
90
93
91
94
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+
92--------------------------------------------------------------------------------
108--------------------------------------------------------------------------------
93checkInternalUrl :: FilePath -> String -> Checker ()
109checkInternalUrl :: FilePath -> String -> Checker ()
94checkInternalUrl base url = case url' of
110checkInternalUrl base url = case url' of
95− "" -> tell $ mempty {checkerOk = 1}
111+ "" -> ok url
96 _ -> do
112 _ -> do
97− logger <- checkerLogger <$> ask
98 config <- checkerConfig <$> ask
113 config <- checkerConfig <$> ask
99−
100 let dest = destinationDirectory config
114 let dest = destinationDirectory config
101 dir = takeDirectory base
115 dir = takeDirectory base
102 filePath
116 filePath
@@ -104,11 +118,7 @@ checkInternalUrl base url = case url' of
104 | otherwise = dir </> url'
118 | otherwise = dir </> url'
105
119
106 exists <- checkFileExists filePath
120 exists <- checkFileExists filePath
107− if exists
121+ if exists then ok url else faulty url
108− then tell $ mempty {checkerOk = 1}
109− else do
110− tell $ mempty {checkerFaulty = 1}
111− Logger.error logger $ base ++ ": broken link to " ++ show url
112 where
122 where
113 url' = stripFragments url
123 url' = stripFragments url
114
124
@@ -118,7 +128,22 @@ checkExternalUrl :: String -> Checker ()
118checkExternalUrl url = do
128checkExternalUrl url = do
119 logger <- checkerLogger <$> ask
129 logger <- checkerLogger <$> ask
120 Logger.message logger $ "Not checking external url " ++ url
130 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
122
147
123
148
124--------------------------------------------------------------------------------
149--------------------------------------------------------------------------------