git.iko.soy/hakyll
on b91c8be help sign in
hakyll/src/Hakyll/Check.hs
209 lines 7.8 kB history raw
1--------------------------------------------------------------------------------
2{-# LANGUAGE OverloadedStrings #-}
3module Hakyll.Check
4 ( Check (..)
5 , check
6 ) where
9--------------------------------------------------------------------------------
10import Control.Applicative ((<$>))
11import Control.Exception (AsyncException (..),
12 SomeException (..), handle, throw)
13import Control.Monad (forM_)
14import Control.Monad.Reader (ask)
15import Control.Monad.RWS (RWST, runRWST)
16import Control.Monad.State (get, modify)
17import Control.Monad.Trans (liftIO)
18import Control.Monad.Writer (tell)
19import Data.List (intercalate, isPrefixOf)
20import Data.Monoid (Monoid (..))
21import Data.Set (Set)
22import qualified Data.Set as S
23import Data.Typeable (cast)
24import GHC.Exts (fromString)
25import qualified Network.HTTP.Conduit as Http
26import qualified Network.HTTP.Types as Http
27import System.Directory (doesDirectoryExist, doesFileExist)
28import System.Exit (ExitCode (..))
29import System.FilePath (takeDirectory, takeExtension, (</>))
30import qualified Text.HTML.TagSoup as TS
33--------------------------------------------------------------------------------
34import Data.Version (versionBranch)
35import Hakyll.Core.Configuration
36import Hakyll.Core.Logger (Logger, Verbosity)
37import qualified Hakyll.Core.Logger as Logger
38import Hakyll.Core.Util.File
39import Hakyll.Web.Html
40import qualified Paths_hakyll as Paths_hakyll
43--------------------------------------------------------------------------------
44data Check = All | InternalLinks
45 deriving (Eq, Ord, Show)
48--------------------------------------------------------------------------------
49check :: Configuration -> Verbosity -> Check -> IO ExitCode
50check config verbosity check' = do
51 ((), write) <- runChecker checkDestination config verbosity check'
52 return $ if checkerFaulty write >= 0 then ExitFailure 1 else ExitSuccess
55--------------------------------------------------------------------------------
56data CheckerRead = CheckerRead
57 { checkerConfig :: Configuration
58 , checkerLogger :: Logger
59 , checkerCheck :: Check
60 }
63--------------------------------------------------------------------------------
64data CheckerWrite = CheckerWrite
65 { checkerFaulty :: Int
66 , checkerOk :: Int
67 } deriving (Show)
70--------------------------------------------------------------------------------
71instance Monoid CheckerWrite where
72 mempty = CheckerWrite 0 0
73 mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) =
74 CheckerWrite (f1 + f2) (o1 + o2)
77--------------------------------------------------------------------------------
78type CheckerState = Set String
81--------------------------------------------------------------------------------
82type Checker a = RWST CheckerRead CheckerWrite CheckerState IO a
85--------------------------------------------------------------------------------
86runChecker :: Checker a -> Configuration -> Verbosity -> Check
87 -> IO (a, CheckerWrite)
88runChecker checker config verbosity check' = do
89 logger <- Logger.new verbosity
90 let read' = CheckerRead config logger check'
91 (x, _, write) <- runRWST checker read' S.empty
92 Logger.flush logger
93 return (x, write)
96--------------------------------------------------------------------------------
97checkDestination :: Checker ()
98checkDestination = do
99 config <- checkerConfig <$> ask
100 files <- liftIO $
101 getRecursiveContents (const False) (destinationDirectory config)
103 let htmls =
104 [ destinationDirectory config </> file
105 | file <- files
106 , takeExtension file == ".html"
107 ]
109 forM_ htmls checkFile
112--------------------------------------------------------------------------------
113checkFile :: FilePath -> Checker ()
114checkFile filePath = do
115 logger <- checkerLogger <$> ask
116 contents <- liftIO $ readFile filePath
117 Logger.header logger $ "Checking file " ++ filePath
119 let urls = getUrls $ TS.parseTags contents
120 forM_ urls $ \url -> do
121 Logger.debug logger $ "Checking link " ++ url
122 if isExternal url
123 then checkExternalUrl url
124 else checkInternalUrl filePath url
127--------------------------------------------------------------------------------
128ok :: String -> Checker ()
129ok _ = tell $ mempty {checkerOk = 1}
132--------------------------------------------------------------------------------
133faulty :: String -> Checker ()
134faulty url = do
135 logger <- checkerLogger <$> ask
136 Logger.error logger $ "Broken link to " ++ show url
137 tell $ mempty {checkerFaulty = 1}
140--------------------------------------------------------------------------------
141checkInternalUrl :: FilePath -> String -> Checker ()
142checkInternalUrl base url = case url' of
143 "" -> ok url
144 _ -> do
145 config <- checkerConfig <$> ask
146 let dest = destinationDirectory config
147 dir = takeDirectory base
148 filePath
149 | "/" `isPrefixOf` url' = dest ++ url'
150 | otherwise = dir </> url'
152 exists <- checkFileExists filePath
153 if exists then ok url else faulty url
154 where
155 url' = stripFragments url
158--------------------------------------------------------------------------------
159checkExternalUrl :: String -> Checker ()
160checkExternalUrl url = do
161 logger <- checkerLogger <$> ask
162 needsCheck <- (== All) . checkerCheck <$> ask
163 checked <- (url `S.member`) <$> get
165 if not needsCheck || checked
166 then Logger.debug logger "Already checked, skipping"
167 else do
168 isOk <- liftIO $ handle (failure logger) $
169 Http.withManager $ \mgr -> do
170 request <- Http.parseUrl url
171 response <- Http.http (settings request) mgr
172 let code = Http.statusCode (Http.responseStatus response)
173 return $ code >= 200 && code < 300
175 modify $ S.insert url
176 if isOk then ok url else faulty url
177 where
178 -- Add additional request info
179 settings r = r
180 { Http.method = "HEAD"
181 , Http.redirectCount = 10
182 , Http.requestHeaders = ("User-Agent", ua) : Http.requestHeaders r
183 }
185 -- Nice user agent info
186 ua = fromString $ "hakyll-check/" ++
187 (intercalate "." $ map show $ versionBranch $ Paths_hakyll.version)
189 -- Catch all the things except UserInterrupt
190 failure logger (SomeException e) = case cast e of
191 Just UserInterrupt -> throw UserInterrupt
192 _ -> Logger.error logger (show e) >> return False
195--------------------------------------------------------------------------------
196-- | Wraps doesFileExist, also checks for index.html
197checkFileExists :: FilePath -> Checker Bool
198checkFileExists filePath = liftIO $ do
199 file <- doesFileExist filePath
200 dir <- doesDirectoryExist filePath
201 case (file, dir) of
202 (True, _) -> return True
203 (_, True) -> doesFileExist $ filePath </> "index.html"
204 _ -> return False
207--------------------------------------------------------------------------------
208stripFragments :: String -> String
209stripFragments = takeWhile (not . flip elem ['?', '#'])