{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Hakyll.Check
( Check (..)
, check
) where
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar,
readMVar)
import Control.Exception (SomeAsyncException (..),
SomeException (..), throw, try)
import Control.Monad (foldM, forM_)
import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Control.Monad.State (StateT, get, modify, runStateT)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Resource (runResourceT)
import Data.List (isPrefixOf)
import qualified Data.Map.Lazy as Map
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup (Semigroup (..))
#endif
import Network.URI (unEscapeString)
import System.Directory (doesDirectoryExist,
doesFileExist)
import System.Exit (ExitCode (..))
import System.FilePath (takeDirectory, takeExtension,
(</>))
import qualified Text.HTML.TagSoup as TS
#ifdef CHECK_EXTERNAL
import Data.List (intercalate)
import Data.Typeable (cast)
import Data.Version (versionBranch)
import GHC.Exts (fromString)
import qualified Network.HTTP.Conduit as Http
import qualified Network.HTTP.Types as Http
import qualified Paths_hakyll as Paths_hakyll
#endif
import Hakyll.Core.Configuration
import Hakyll.Core.Logger (Logger)
import qualified Hakyll.Core.Logger as Logger
import Hakyll.Core.Util.File
import Hakyll.Web.Html
data Check = All | InternalLinks
deriving (Check -> Check -> Bool
(Check -> Check -> Bool) -> (Check -> Check -> Bool) -> Eq Check
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Check -> Check -> Bool
$c/= :: Check -> Check -> Bool
== :: Check -> Check -> Bool
$c== :: Check -> Check -> Bool
Eq, Eq Check
Eq Check
-> (Check -> Check -> Ordering)
-> (Check -> Check -> Bool)
-> (Check -> Check -> Bool)
-> (Check -> Check -> Bool)
-> (Check -> Check -> Bool)
-> (Check -> Check -> Check)
-> (Check -> Check -> Check)
-> Ord Check
Check -> Check -> Bool
Check -> Check -> Ordering
Check -> Check -> Check
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Check -> Check -> Check
$cmin :: Check -> Check -> Check
max :: Check -> Check -> Check
$cmax :: Check -> Check -> Check
>= :: Check -> Check -> Bool
$c>= :: Check -> Check -> Bool
> :: Check -> Check -> Bool
$c> :: Check -> Check -> Bool
<= :: Check -> Check -> Bool
$c<= :: Check -> Check -> Bool
< :: Check -> Check -> Bool
$c< :: Check -> Check -> Bool
compare :: Check -> Check -> Ordering
$ccompare :: Check -> Check -> Ordering
Ord, Int -> Check -> ShowS
[Check] -> ShowS
Check -> [Char]
(Int -> Check -> ShowS)
-> (Check -> [Char]) -> ([Check] -> ShowS) -> Show Check
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Check] -> ShowS
$cshowList :: [Check] -> ShowS
show :: Check -> [Char]
$cshow :: Check -> [Char]
showsPrec :: Int -> Check -> ShowS
$cshowsPrec :: Int -> Check -> ShowS
Show)
check :: Configuration -> Logger -> Check -> IO ExitCode
check :: Configuration -> Logger -> Check -> IO ExitCode
check Configuration
config Logger
logger Check
check' = do
((), CheckerState
state) <- Checker ()
-> Configuration -> Logger -> Check -> IO ((), CheckerState)
forall a.
Checker a
-> Configuration -> Logger -> Check -> IO (a, CheckerState)
runChecker Checker ()
checkDestination Configuration
config Logger
logger Check
check'
Int
failed <- CheckerState -> IO Int
countFailedLinks CheckerState
state
ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> IO ExitCode) -> ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ if Int
failed Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int -> ExitCode
ExitFailure Int
1 else ExitCode
ExitSuccess
countFailedLinks :: CheckerState -> IO Int
countFailedLinks :: CheckerState -> IO Int
countFailedLinks CheckerState
state = (Int -> MVar CheckerWrite -> IO Int)
-> Int -> [MVar CheckerWrite] -> IO Int
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Int -> MVar CheckerWrite -> IO Int
addIfFailure Int
0 (CheckerState -> [MVar CheckerWrite]
forall k a. Map k a -> [a]
Map.elems CheckerState
state)
where addIfFailure :: Int -> MVar CheckerWrite -> IO Int
addIfFailure Int
failures MVar CheckerWrite
mvar = do
CheckerWrite
checkerWrite <- MVar CheckerWrite -> IO CheckerWrite
forall a. MVar a -> IO a
readMVar MVar CheckerWrite
mvar
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
failures Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CheckerWrite -> Int
checkerFaulty CheckerWrite
checkerWrite
data CheckerRead = CheckerRead
{ CheckerRead -> Configuration
checkerConfig :: Configuration
, CheckerRead -> Logger
checkerLogger :: Logger
, CheckerRead -> Check
checkerCheck :: Check
}
data CheckerWrite = CheckerWrite
{ CheckerWrite -> Int
checkerFaulty :: Int
, CheckerWrite -> Int
checkerOk :: Int
} deriving (Int -> CheckerWrite -> ShowS
[CheckerWrite] -> ShowS
CheckerWrite -> [Char]
(Int -> CheckerWrite -> ShowS)
-> (CheckerWrite -> [Char])
-> ([CheckerWrite] -> ShowS)
-> Show CheckerWrite
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CheckerWrite] -> ShowS
$cshowList :: [CheckerWrite] -> ShowS
show :: CheckerWrite -> [Char]
$cshow :: CheckerWrite -> [Char]
showsPrec :: Int -> CheckerWrite -> ShowS
$cshowsPrec :: Int -> CheckerWrite -> ShowS
Show)
#if MIN_VERSION_base(4,9,0)
instance Semigroup CheckerWrite where
<> :: CheckerWrite -> CheckerWrite -> CheckerWrite
(<>) (CheckerWrite Int
f1 Int
o1) (CheckerWrite Int
f2 Int
o2) =
Int -> Int -> CheckerWrite
CheckerWrite (Int
f1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
f2) (Int
o1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
o2)
instance Monoid CheckerWrite where
mempty :: CheckerWrite
mempty = Int -> Int -> CheckerWrite
CheckerWrite Int
0 Int
0
mappend :: CheckerWrite -> CheckerWrite -> CheckerWrite
mappend = CheckerWrite -> CheckerWrite -> CheckerWrite
forall a. Semigroup a => a -> a -> a
(<>)
#else
instance Monoid CheckerWrite where
mempty = CheckerWrite 0 0
mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) =
CheckerWrite (f1 + f2) (o1 + o2)
#endif
type CheckerState = Map.Map URL (MVar CheckerWrite)
type Checker a = ReaderT CheckerRead (StateT CheckerState IO) a
type URL = String
runChecker :: Checker a -> Configuration -> Logger -> Check
-> IO (a, CheckerState)
runChecker :: forall a.
Checker a
-> Configuration -> Logger -> Check -> IO (a, CheckerState)
runChecker Checker a
checker Configuration
config Logger
logger Check
check' = do
let read' :: CheckerRead
read' = CheckerRead :: Configuration -> Logger -> Check -> CheckerRead
CheckerRead
{ checkerConfig :: Configuration
checkerConfig = Configuration
config
, checkerLogger :: Logger
checkerLogger = Logger
logger
, checkerCheck :: Check
checkerCheck = Check
check'
}
Logger -> IO ()
Logger.flush Logger
logger
StateT CheckerState IO a -> CheckerState -> IO (a, CheckerState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Checker a -> CheckerRead -> StateT CheckerState IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Checker a
checker CheckerRead
read') CheckerState
forall k a. Map k a
Map.empty
checkDestination :: Checker ()
checkDestination :: Checker ()
checkDestination = do
Configuration
config <- CheckerRead -> Configuration
checkerConfig (CheckerRead -> Configuration)
-> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
-> ReaderT CheckerRead (StateT CheckerState IO) Configuration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
forall r (m :: * -> *). MonadReader r m => m r
ask
[[Char]]
files <- IO [[Char]]
-> ReaderT CheckerRead (StateT CheckerState IO) [[Char]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]]
-> ReaderT CheckerRead (StateT CheckerState IO) [[Char]])
-> IO [[Char]]
-> ReaderT CheckerRead (StateT CheckerState IO) [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> IO Bool) -> [Char] -> IO [[Char]]
getRecursiveContents
(IO Bool -> [Char] -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> [Char] -> IO Bool) -> IO Bool -> [Char] -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (Configuration -> [Char]
destinationDirectory Configuration
config)
let htmls :: [[Char]]
htmls =
[ Configuration -> [Char]
destinationDirectory Configuration
config [Char] -> ShowS
</> [Char]
file
| [Char]
file <- [[Char]]
files
, ShowS
takeExtension [Char]
file [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".html"
]
[[Char]] -> ([Char] -> Checker ()) -> Checker ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
htmls [Char] -> Checker ()
checkFile
checkFile :: FilePath -> Checker ()
checkFile :: [Char] -> Checker ()
checkFile [Char]
filePath = do
Logger
logger <- CheckerRead -> Logger
checkerLogger (CheckerRead -> Logger)
-> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
-> ReaderT CheckerRead (StateT CheckerState IO) Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
forall r (m :: * -> *). MonadReader r m => m r
ask
[Char]
contents <- IO [Char] -> ReaderT CheckerRead (StateT CheckerState IO) [Char]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> ReaderT CheckerRead (StateT CheckerState IO) [Char])
-> IO [Char] -> ReaderT CheckerRead (StateT CheckerState IO) [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
readFile [Char]
filePath
Logger -> [Char] -> Checker ()
forall (m :: * -> *). MonadIO m => Logger -> [Char] -> m ()
Logger.header Logger
logger ([Char] -> Checker ()) -> [Char] -> Checker ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Checking file " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
filePath
let urls :: [[Char]]
urls = [Tag [Char]] -> [[Char]]
getUrls ([Tag [Char]] -> [[Char]]) -> [Tag [Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Tag [Char]]
forall str. StringLike str => str -> [Tag str]
TS.parseTags [Char]
contents
[[Char]] -> ([Char] -> Checker ()) -> Checker ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
urls (([Char] -> Checker ()) -> Checker ())
-> ([Char] -> Checker ()) -> Checker ()
forall a b. (a -> b) -> a -> b
$ \[Char]
url -> do
Logger -> [Char] -> Checker ()
forall (m :: * -> *). MonadIO m => Logger -> [Char] -> m ()
Logger.debug Logger
logger ([Char] -> Checker ()) -> [Char] -> Checker ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Checking link " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
url
MVar CheckerWrite
m <- IO (MVar CheckerWrite)
-> ReaderT CheckerRead (StateT CheckerState IO) (MVar CheckerWrite)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar CheckerWrite)
forall a. IO (MVar a)
newEmptyMVar
[Char] -> [Char] -> MVar CheckerWrite -> Checker ()
checkUrlIfNeeded [Char]
filePath (ShowS
canonicalizeUrl [Char]
url) MVar CheckerWrite
m
where
canonicalizeUrl :: ShowS
canonicalizeUrl [Char]
url = if [Char] -> Bool
schemeRelative [Char]
url then [Char]
"http:" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
url else [Char]
url
schemeRelative :: [Char] -> Bool
schemeRelative = [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
"//"
checkUrlIfNeeded :: FilePath -> URL -> MVar CheckerWrite -> Checker ()
checkUrlIfNeeded :: [Char] -> [Char] -> MVar CheckerWrite -> Checker ()
checkUrlIfNeeded [Char]
filepath [Char]
url MVar CheckerWrite
m = do
Logger
logger <- CheckerRead -> Logger
checkerLogger (CheckerRead -> Logger)
-> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
-> ReaderT CheckerRead (StateT CheckerState IO) Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
forall r (m :: * -> *). MonadReader r m => m r
ask
Bool
needsCheck <- (Check -> Check -> Bool
forall a. Eq a => a -> a -> Bool
== Check
All) (Check -> Bool) -> (CheckerRead -> Check) -> CheckerRead -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckerRead -> Check
checkerCheck (CheckerRead -> Bool)
-> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
-> ReaderT CheckerRead (StateT CheckerState IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
forall r (m :: * -> *). MonadReader r m => m r
ask
Bool
checked <- ([Char]
url [Char] -> CheckerState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member`) (CheckerState -> Bool)
-> ReaderT CheckerRead (StateT CheckerState IO) CheckerState
-> ReaderT CheckerRead (StateT CheckerState IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT CheckerRead (StateT CheckerState IO) CheckerState
forall s (m :: * -> *). MonadState s m => m s
get
if Bool -> Bool
not Bool
needsCheck Bool -> Bool -> Bool
|| Bool
checked
then Logger -> [Char] -> Checker ()
forall (m :: * -> *). MonadIO m => Logger -> [Char] -> m ()
Logger.debug Logger
logger [Char]
"Already checked, skipping"
else do (CheckerState -> CheckerState) -> Checker ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CheckerState -> CheckerState) -> Checker ())
-> (CheckerState -> CheckerState) -> Checker ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MVar CheckerWrite -> CheckerState -> CheckerState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
url MVar CheckerWrite
m
[Char] -> [Char] -> Checker ()
checkUrl [Char]
filepath [Char]
url
checkUrl :: FilePath -> URL -> Checker ()
checkUrl :: [Char] -> [Char] -> Checker ()
checkUrl [Char]
filePath [Char]
url
| [Char] -> Bool
isExternal [Char]
url = [Char] -> Checker ()
checkExternalUrl [Char]
url
| [Char] -> Bool
hasProtocol [Char]
url = [Char] -> Maybe [Char] -> Checker ()
skip [Char]
url (Maybe [Char] -> Checker ()) -> Maybe [Char] -> Checker ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Unknown protocol, skipping"
| Bool
otherwise = [Char] -> [Char] -> Checker ()
checkInternalUrl [Char]
filePath [Char]
url
where
validProtoChars :: [Char]
validProtoChars = [Char
'A'..Char
'Z'] [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9'] [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"+-."
hasProtocol :: [Char] -> Bool
hasProtocol [Char]
str = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') [Char]
str of
([Char]
proto, Char
':' : [Char]
_) -> (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
validProtoChars) [Char]
proto
([Char], [Char])
_ -> Bool
False
ok :: URL -> Checker ()
ok :: [Char] -> Checker ()
ok [Char]
url = [Char] -> CheckerWrite -> Checker ()
putCheckResult [Char]
url CheckerWrite
forall a. Monoid a => a
mempty {checkerOk :: Int
checkerOk = Int
1}
skip :: URL -> Maybe String -> Checker ()
skip :: [Char] -> Maybe [Char] -> Checker ()
skip [Char]
url Maybe [Char]
maybeReason = do
Logger
logger <- CheckerRead -> Logger
checkerLogger (CheckerRead -> Logger)
-> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
-> ReaderT CheckerRead (StateT CheckerState IO) Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
forall r (m :: * -> *). MonadReader r m => m r
ask
case Maybe [Char]
maybeReason of
Maybe [Char]
Nothing -> () -> Checker ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just [Char]
reason -> Logger -> [Char] -> Checker ()
forall (m :: * -> *). MonadIO m => Logger -> [Char] -> m ()
Logger.debug Logger
logger [Char]
reason
[Char] -> CheckerWrite -> Checker ()
putCheckResult [Char]
url CheckerWrite
forall a. Monoid a => a
mempty {checkerOk :: Int
checkerOk = Int
1}
faulty :: URL -> Maybe String -> Checker ()
faulty :: [Char] -> Maybe [Char] -> Checker ()
faulty [Char]
url Maybe [Char]
reason = do
Logger
logger <- CheckerRead -> Logger
checkerLogger (CheckerRead -> Logger)
-> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
-> ReaderT CheckerRead (StateT CheckerState IO) Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
forall r (m :: * -> *). MonadReader r m => m r
ask
Logger -> [Char] -> Checker ()
forall (m :: * -> *). MonadIO m => Logger -> [Char] -> m ()
Logger.error Logger
logger ([Char] -> Checker ()) -> [Char] -> Checker ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Broken link to " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
url [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
explanation
[Char] -> CheckerWrite -> Checker ()
putCheckResult [Char]
url CheckerWrite
forall a. Monoid a => a
mempty {checkerFaulty :: Int
checkerFaulty = Int
1}
where
formatExplanation :: ShowS
formatExplanation = ([Char]
" (" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")")
explanation :: [Char]
explanation = [Char] -> ShowS -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ShowS
formatExplanation Maybe [Char]
reason
putCheckResult :: URL -> CheckerWrite -> Checker ()
putCheckResult :: [Char] -> CheckerWrite -> Checker ()
putCheckResult [Char]
url CheckerWrite
result = do
CheckerState
state <- ReaderT CheckerRead (StateT CheckerState IO) CheckerState
forall s (m :: * -> *). MonadState s m => m s
get
let maybeMVar :: Maybe (MVar CheckerWrite)
maybeMVar = [Char] -> CheckerState -> Maybe (MVar CheckerWrite)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
url CheckerState
state
case Maybe (MVar CheckerWrite)
maybeMVar of
Just MVar CheckerWrite
m -> IO () -> Checker ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Checker ()) -> IO () -> Checker ()
forall a b. (a -> b) -> a -> b
$ MVar CheckerWrite -> CheckerWrite -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar CheckerWrite
m CheckerWrite
result
Maybe (MVar CheckerWrite)
Nothing -> do
Logger
logger <- CheckerRead -> Logger
checkerLogger (CheckerRead -> Logger)
-> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
-> ReaderT CheckerRead (StateT CheckerState IO) Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
forall r (m :: * -> *). MonadReader r m => m r
ask
Logger -> [Char] -> Checker ()
forall (m :: * -> *). MonadIO m => Logger -> [Char] -> m ()
Logger.debug Logger
logger [Char]
"Failed to find existing entry for checked URL"
checkInternalUrl :: FilePath -> URL -> Checker ()
checkInternalUrl :: [Char] -> [Char] -> Checker ()
checkInternalUrl [Char]
base [Char]
url = case [Char]
url' of
[Char]
"" -> [Char] -> Checker ()
ok [Char]
url
[Char]
_ -> do
Configuration
config <- CheckerRead -> Configuration
checkerConfig (CheckerRead -> Configuration)
-> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
-> ReaderT CheckerRead (StateT CheckerState IO) Configuration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT CheckerRead (StateT CheckerState IO) CheckerRead
forall r (m :: * -> *). MonadReader r m => m r
ask
let dest :: [Char]
dest = Configuration -> [Char]
destinationDirectory Configuration
config
dir :: [Char]
dir = ShowS
takeDirectory [Char]
base
filePath :: [Char]
filePath
| [Char]
"/" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
url' = [Char]
dest [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
url'
| Bool
otherwise = [Char]
dir [Char] -> ShowS
</> [Char]
url'
Bool
exists <- [Char] -> ReaderT CheckerRead (StateT CheckerState IO) Bool
checkFileExists [Char]
filePath
if Bool
exists then [Char] -> Checker ()
ok [Char]
url else [Char] -> Maybe [Char] -> Checker ()
faulty [Char]
url Maybe [Char]
forall a. Maybe a
Nothing
where
url' :: [Char]
url' = ShowS
stripFragments ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
unEscapeString [Char]
url
checkExternalUrl :: URL -> Checker ()
#ifdef CHECK_EXTERNAL
checkExternalUrl :: [Char] -> Checker ()
checkExternalUrl [Char]
url = do
Either SomeException Bool
result <- [Char] -> Checker (Either SomeException Bool)
requestExternalUrl [Char]
url
case Either SomeException Bool
result of
Left (SomeException e
e) ->
case (e -> Maybe SomeAsyncException
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e :: Maybe SomeAsyncException) of
Just SomeAsyncException
ae -> SomeAsyncException -> Checker ()
forall a e. Exception e => e -> a
throw SomeAsyncException
ae
Maybe SomeAsyncException
_ -> [Char] -> Maybe [Char] -> Checker ()
faulty [Char]
url ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ e -> [Char]
forall {a}. (Typeable a, Show a) => a -> [Char]
showException e
e)
Right Bool
_ -> [Char] -> Checker ()
ok [Char]
url
where
showException :: a -> [Char]
showException a
e = case a -> Maybe HttpException
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
e of
Just (Http.HttpExceptionRequest Request
_ HttpExceptionContent
e') -> HttpExceptionContent -> [Char]
forall a. Show a => a -> [Char]
show HttpExceptionContent
e'
Maybe HttpException
_ -> [[Char]] -> [Char]
forall a. [a] -> a
head ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
words ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ a -> [Char]
forall a. Show a => a -> [Char]
show a
e
requestExternalUrl :: URL -> Checker (Either SomeException Bool)
requestExternalUrl :: [Char] -> Checker (Either SomeException Bool)
requestExternalUrl [Char]
url = IO (Either SomeException Bool)
-> Checker (Either SomeException Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException Bool)
-> Checker (Either SomeException Bool))
-> IO (Either SomeException Bool)
-> Checker (Either SomeException Bool)
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO (Either SomeException Bool)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Bool -> IO (Either SomeException Bool))
-> IO Bool -> IO (Either SomeException Bool)
forall a b. (a -> b) -> a -> b
$ do
Manager
mgr <- ManagerSettings -> IO Manager
Http.newManager ManagerSettings
Http.tlsManagerSettings
ResourceT IO Bool -> IO Bool
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO Bool -> IO Bool) -> ResourceT IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
Request
request <- [Char] -> ResourceT IO Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
Http.parseRequest [Char]
url
Response (ConduitM Any ByteString (ResourceT IO) ())
response <- Request
-> Manager
-> ResourceT
IO (Response (ConduitM Any ByteString (ResourceT IO) ()))
forall (m :: * -> *) i.
MonadResource m =>
Request -> Manager -> m (Response (ConduitM i ByteString m ()))
Http.http (Request -> Request
settings Request
request) Manager
mgr
let code :: Int
code = Status -> Int
Http.statusCode (Response (ConduitM Any ByteString (ResourceT IO) ()) -> Status
forall body. Response body -> Status
Http.responseStatus Response (ConduitM Any ByteString (ResourceT IO) ())
response)
Bool -> ResourceT IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ResourceT IO Bool) -> Bool -> ResourceT IO Bool
forall a b. (a -> b) -> a -> b
$ Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300
where
settings :: Request -> Request
settings Request
r = Request
r
{ method :: ByteString
Http.method = ByteString
"HEAD"
, redirectCount :: Int
Http.redirectCount = Int
10
, requestHeaders :: RequestHeaders
Http.requestHeaders = (HeaderName
"User-Agent", ByteString
ua) (HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: Request -> RequestHeaders
Http.requestHeaders Request
r
}
ua :: ByteString
ua = [Char] -> ByteString
forall a. IsString a => [Char] -> a
fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"hakyll-check/" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
forall a. Show a => a -> [Char]
show ([Int] -> [[Char]]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Version -> [Int]
versionBranch Version
Paths_hakyll.version)
#else
checkExternalUrl url = skip url Nothing
#endif
checkFileExists :: FilePath -> Checker Bool
checkFileExists :: [Char] -> ReaderT CheckerRead (StateT CheckerState IO) Bool
checkFileExists [Char]
filePath = IO Bool -> ReaderT CheckerRead (StateT CheckerState IO) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ReaderT CheckerRead (StateT CheckerState IO) Bool)
-> IO Bool -> ReaderT CheckerRead (StateT CheckerState IO) Bool
forall a b. (a -> b) -> a -> b
$ do
Bool
file <- [Char] -> IO Bool
doesFileExist [Char]
filePath
Bool
dir <- [Char] -> IO Bool
doesDirectoryExist [Char]
filePath
case (Bool
file, Bool
dir) of
(Bool
True, Bool
_) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
(Bool
_, Bool
True) -> [Char] -> IO Bool
doesFileExist ([Char] -> IO Bool) -> [Char] -> IO Bool
forall a b. (a -> b) -> a -> b
$ [Char]
filePath [Char] -> ShowS
</> [Char]
"index.html"
(Bool, Bool)
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
stripFragments :: String -> String
stripFragments :: ShowS
stripFragments = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> [Char] -> Bool) -> [Char] -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
'?', Char
'#'])