--------------------------------------------------------------------------------
{-# 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
        -- 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 (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
        -- 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
_                                     -> [[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
        -- Add additional request info
        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
            }

        -- 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 (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
'#'])