git.iko.soy/hakyll
on 792fcdf help sign in
hakyll/src/Hakyll/Check.hs
244 lines 8.8 kB history raw
1--------------------------------------------------------------------------------
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE OverloadedStrings #-}
4module Hakyll.Check
5 ( Check (..)
6 , check
7 ) where
10--------------------------------------------------------------------------------
11import Control.Applicative ((<$>))
12import Control.Monad (forM_)
13import Control.Monad.Reader (ask)
14import Control.Monad.RWS (RWST, runRWST)
15import Control.Monad.Trans (liftIO)
16import Control.Monad.Writer (tell)
17import Data.List (isPrefixOf)
18import Data.Monoid (Monoid (..))
19import Data.Set (Set)
20import qualified Data.Set as S
21import System.Directory (doesDirectoryExist, doesFileExist)
22import System.Exit (ExitCode (..))
23import System.FilePath (takeDirectory, takeExtension, (</>))
24import qualified Text.HTML.TagSoup as TS
27--------------------------------------------------------------------------------
28#ifdef CHECK_EXTERNAL
29import Control.Exception (AsyncException (..),
30 SomeException (..), handle, throw)
31import Control.Monad.State (get, modify)
32import Data.List (intercalate)
33import Data.Typeable (cast)
34import Data.Version (versionBranch)
35import GHC.Exts (fromString)
36import qualified Network.HTTP.Conduit as Http
37import qualified Network.HTTP.Types as Http
38import qualified Paths_hakyll as Paths_hakyll
39#endif
42--------------------------------------------------------------------------------
43import Hakyll.Core.Configuration
44import Hakyll.Core.Logger (Logger, Verbosity)
45import qualified Hakyll.Core.Logger as Logger
46import Hakyll.Core.Util.File
47import Hakyll.Web.Html
50--------------------------------------------------------------------------------
51data Check = All | InternalLinks
52 deriving (Eq, Ord, Show)
55--------------------------------------------------------------------------------
56check :: Configuration -> Verbosity -> Check -> IO ExitCode
57check config verbosity check' = do
58 ((), write) <- runChecker checkDestination config verbosity check'
59 return $ if checkerFaulty write >= 0 then ExitFailure 1 else ExitSuccess
62--------------------------------------------------------------------------------
63data CheckerRead = CheckerRead
64 { checkerConfig :: Configuration
65 , checkerLogger :: Logger
66 , checkerCheck :: Check
67 }
70--------------------------------------------------------------------------------
71data CheckerWrite = CheckerWrite
72 { checkerFaulty :: Int
73 , checkerOk :: Int
74 } deriving (Show)
77--------------------------------------------------------------------------------
78instance Monoid CheckerWrite where
79 mempty = CheckerWrite 0 0
80 mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) =
81 CheckerWrite (f1 + f2) (o1 + o2)
84--------------------------------------------------------------------------------
85type CheckerState = Set String
88--------------------------------------------------------------------------------
89type Checker a = RWST CheckerRead CheckerWrite CheckerState IO a
92--------------------------------------------------------------------------------
93runChecker :: Checker a -> Configuration -> Verbosity -> Check
94 -> IO (a, CheckerWrite)
95runChecker checker config verbosity check' = do
96 logger <- Logger.new verbosity
97 let read' = CheckerRead
98 { checkerConfig = config
99 , checkerLogger = logger
100 , checkerCheck = check'
101 }
103 (x, _, write) <- runRWST checker read' S.empty
104 Logger.flush logger
105 return (x, write)
108--------------------------------------------------------------------------------
109checkDestination :: Checker ()
110checkDestination = do
111 config <- checkerConfig <$> ask
112 files <- liftIO $
113 getRecursiveContents (const False) (destinationDirectory config)
115 let htmls =
116 [ destinationDirectory config </> file
117 | file <- files
118 , takeExtension file == ".html"
119 ]
121 forM_ htmls checkFile
124--------------------------------------------------------------------------------
125checkFile :: FilePath -> Checker ()
126checkFile filePath = do
127 logger <- checkerLogger <$> ask
128 contents <- liftIO $ readFile filePath
129 Logger.header logger $ "Checking file " ++ filePath
131 let urls = getUrls $ TS.parseTags contents
132 forM_ urls $ \url -> do
133 Logger.debug logger $ "Checking link " ++ url
134 checkUrl filePath url
137--------------------------------------------------------------------------------
138checkUrl :: FilePath -> String -> Checker ()
139checkUrl filePath url
140 | isExternal url = checkExternalUrl url
141 | hasProtocol url = skip "Unknown protocol, skipping"
142 | otherwise = checkInternalUrl filePath url
143 where
144 validProtoChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "+-."
145 hasProtocol str = case break (== ':') str of
146 (proto, ':' : _) -> all (`elem` validProtoChars) proto
147 _ -> False
150--------------------------------------------------------------------------------
151ok :: String -> Checker ()
152ok _ = tell $ mempty {checkerOk = 1}
155--------------------------------------------------------------------------------
156skip :: String -> Checker ()
157skip reason = do
158 logger <- checkerLogger <$> ask
159 Logger.debug logger $ reason
160 tell $ mempty {checkerOk = 1}
162--------------------------------------------------------------------------------
163faulty :: String -> Checker ()
164faulty url = do
165 logger <- checkerLogger <$> ask
166 Logger.error logger $ "Broken link to " ++ show url
167 tell $ mempty {checkerFaulty = 1}
170--------------------------------------------------------------------------------
171checkInternalUrl :: FilePath -> String -> Checker ()
172checkInternalUrl base url = case url' of
173 "" -> ok url
174 _ -> do
175 config <- checkerConfig <$> ask
176 let dest = destinationDirectory config
177 dir = takeDirectory base
178 filePath
179 | "/" `isPrefixOf` url' = dest ++ url'
180 | otherwise = dir </> url'
182 exists <- checkFileExists filePath
183 if exists then ok url else faulty url
184 where
185 url' = stripFragments url
188--------------------------------------------------------------------------------
189checkExternalUrl :: String -> Checker ()
190#ifdef CHECK_EXTERNAL
191checkExternalUrl url = do
192 logger <- checkerLogger <$> ask
193 needsCheck <- (== All) . checkerCheck <$> ask
194 checked <- (url `S.member`) <$> get
196 if not needsCheck || checked
197 then Logger.debug logger "Already checked, skipping"
198 else do
199 isOk <- liftIO $ handle (failure logger) $
200 Http.withManager $ \mgr -> do
201 request <- Http.parseUrl url
202 response <- Http.http (settings request) mgr
203 let code = Http.statusCode (Http.responseStatus response)
204 return $ code >= 200 && code < 300
206 modify $ S.insert url
207 if isOk then ok url else faulty url
208 where
209 -- Add additional request info
210 settings r = r
211 { Http.method = "HEAD"
212 , Http.redirectCount = 10
213 , Http.requestHeaders = ("User-Agent", ua) : Http.requestHeaders r
214 }
216 -- Nice user agent info
217 ua = fromString $ "hakyll-check/" ++
218 (intercalate "." $ map show $ versionBranch $ Paths_hakyll.version)
220 -- Catch all the things except UserInterrupt
221 failure logger (SomeException e) = case cast e of
222 Just UserInterrupt -> throw UserInterrupt
223 _ -> Logger.error logger (show e) >> return False
224#else
225checkExternalUrl _ = return ()
226#endif
230--------------------------------------------------------------------------------
231-- | Wraps doesFileExist, also checks for index.html
232checkFileExists :: FilePath -> Checker Bool
233checkFileExists filePath = liftIO $ do
234 file <- doesFileExist filePath
235 dir <- doesDirectoryExist filePath
236 case (file, dir) of
237 (True, _) -> return True
238 (_, True) -> doesFileExist $ filePath </> "index.html"
239 _ -> return False
242--------------------------------------------------------------------------------
243stripFragments :: String -> String
244stripFragments = takeWhile (not . flip elem ['?', '#'])