--------------------------------------------------------------------------------
{-# 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
import           Network.URI                  (unEscapeString)
import           System.Directory             (doesDirectoryExist,
                                               doesFileExist)
import           System.Exit                  (ExitCode (..))
import           System.FilePath              (takeDirectory, (</>))
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
$c== :: Check -> Check -> Bool
== :: Check -> Check -> Bool
$c/= :: Check -> Check -> Bool
/= :: 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
$ccompare :: Check -> Check -> Ordering
compare :: Check -> Check -> Ordering
$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
>= :: Check -> Check -> Bool
$cmax :: Check -> Check -> Check
max :: Check -> Check -> Check
$cmin :: Check -> Check -> Check
min :: Check -> Check -> Check
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
$cshowsPrec :: Int -> Check -> ShowS
showsPrec :: Int -> Check -> ShowS
$cshow :: Check -> [Char]
show :: Check -> [Char]
$cshowList :: [Check] -> ShowS
showList :: [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 a. a -> IO a
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 a. a -> IO a
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
$cshowsPrec :: Int -> CheckerWrite -> ShowS
showsPrec :: Int -> CheckerWrite -> ShowS
$cshow :: CheckerWrite -> [Char]
show :: CheckerWrite -> [Char]
$cshowList :: [CheckerWrite] -> ShowS
showList :: [CheckerWrite] -> ShowS
Show)


--------------------------------------------------------------------------------
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
(<>)


--------------------------------------------------------------------------------
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
                    { checkerConfig :: Configuration
checkerConfig = Configuration
config
                    , checkerLogger :: Logger
checkerLogger = Logger
logger
                    , checkerCheck :: Check
checkerCheck  = Check
check'
                    }
    Logger -> forall (m :: * -> *). MonadIO m => m ()
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 a. IO a -> ReaderT CheckerRead (StateT CheckerState IO) a
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 a. a -> IO a
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
            , Configuration -> [Char] -> Bool
checkHtmlFile Configuration
config [Char]
file
            ]

    [[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 a. IO a -> ReaderT CheckerRead (StateT CheckerState IO) a
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 a. IO a -> ReaderT CheckerRead (StateT CheckerState IO) a
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
        -- Check scheme-relative links
        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 a. Eq a => a -> [a] -> 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 = 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 a. a -> ReaderT CheckerRead (StateT CheckerState IO) a
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 = 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 = 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 a. IO a -> ReaderT CheckerRead (StateT CheckerState IO) a
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
        -- Convert exception to a concise form
        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
_                                     -> case [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 of
              [Char]
w:[[Char]]
_ -> [Char]
w
              []  -> ShowS
forall a. HasCallStack => [Char] -> a
error [Char]
"Hakyll.Check.checkExternalUrl: impossible"

requestExternalUrl :: URL -> Checker (Either SomeException Bool)
requestExternalUrl :: [Char] -> Checker (Either SomeException Bool)
requestExternalUrl [Char]
url = IO (Either SomeException Bool)
-> Checker (Either SomeException Bool)
forall a. IO a -> ReaderT CheckerRead (StateT CheckerState IO) a
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)
        -- Recall that 3XX status codes are redirections, which aren't necessarily errors. 
        Bool -> ResourceT IO Bool
forall a. a -> ResourceT IO a
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
400
    where
        -- Add additional request info
        settings :: Request -> Request
settings Request
r = Request
r
            { Http.method         = "HEAD"
            , Http.redirectCount  = 10
            , Http.requestHeaders = ("User-Agent", ua) : Http.requestHeaders r
            }

        -- Nice user agent info
        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


--------------------------------------------------------------------------------
-- | Wraps doesFileExist, also checks for index.html
checkFileExists :: FilePath -> Checker Bool
checkFileExists :: [Char] -> ReaderT CheckerRead (StateT CheckerState IO) Bool
checkFileExists [Char]
filePath = IO Bool -> ReaderT CheckerRead (StateT CheckerState IO) Bool
forall a. IO a -> ReaderT CheckerRead (StateT CheckerState IO) a
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 a. a -> IO a
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 a. a -> IO a
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 a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
'?', Char
'#'])