--------------------------------------------------------------------------------
{-# 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
$cp1Ord :: Eq Check
Ord, Int -> Check -> ShowS
[Check] -> ShowS
Check -> String
(Int -> Check -> ShowS)
-> (Check -> String) -> ([Check] -> ShowS) -> Show Check
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Check] -> ShowS
$cshowList :: [Check] -> ShowS
show :: Check -> String
$cshow :: Check -> String
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 -> String
(Int -> CheckerWrite -> ShowS)
-> (CheckerWrite -> String)
-> ([CheckerWrite] -> ShowS)
-> Show CheckerWrite
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CheckerWrite] -> ShowS
$cshowList :: [CheckerWrite] -> ShowS
show :: CheckerWrite -> String
$cshow :: CheckerWrite -> String
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 :: 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
    [String]
files  <- IO [String]
-> ReaderT CheckerRead (StateT CheckerState IO) [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String]
 -> ReaderT CheckerRead (StateT CheckerState IO) [String])
-> IO [String]
-> ReaderT CheckerRead (StateT CheckerState IO) [String]
forall a b. (a -> b) -> a -> b
$ (String -> IO Bool) -> String -> IO [String]
getRecursiveContents
        (IO Bool -> String -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> String -> IO Bool) -> IO Bool -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (Configuration -> String
destinationDirectory Configuration
config)

    let htmls :: [String]
htmls =
            [ Configuration -> String
destinationDirectory Configuration
config String -> ShowS
</> String
file
            | String
file <- [String]
files
            , ShowS
takeExtension String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".html"
            ]

    [String] -> (String -> Checker ()) -> Checker ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
htmls String -> Checker ()
checkFile


--------------------------------------------------------------------------------
checkFile :: FilePath -> Checker ()
checkFile :: String -> Checker ()
checkFile String
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
    String
contents <- IO String -> ReaderT CheckerRead (StateT CheckerState IO) String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ReaderT CheckerRead (StateT CheckerState IO) String)
-> IO String -> ReaderT CheckerRead (StateT CheckerState IO) String
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
filePath
    Logger -> String -> Checker ()
forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.header Logger
logger (String -> Checker ()) -> String -> Checker ()
forall a b. (a -> b) -> a -> b
$ String
"Checking file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filePath

    let urls :: [String]
urls = [Tag String] -> [String]
getUrls ([Tag String] -> [String]) -> [Tag String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [Tag String]
forall str. StringLike str => str -> [Tag str]
TS.parseTags String
contents
    [String] -> (String -> Checker ()) -> Checker ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
urls ((String -> Checker ()) -> Checker ())
-> (String -> Checker ()) -> Checker ()
forall a b. (a -> b) -> a -> b
$ \String
url -> do
        Logger -> String -> Checker ()
forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.debug Logger
logger (String -> Checker ()) -> String -> Checker ()
forall a b. (a -> b) -> a -> b
$ String
"Checking link " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
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
        String -> String -> MVar CheckerWrite -> Checker ()
checkUrlIfNeeded String
filePath (ShowS
canonicalizeUrl String
url) MVar CheckerWrite
m
    where
        -- Check scheme-relative links
        canonicalizeUrl :: ShowS
canonicalizeUrl String
url = if String -> Bool
schemeRelative String
url then String
"http:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
url else String
url
        schemeRelative :: String -> Bool
schemeRelative = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"//"


--------------------------------------------------------------------------------
checkUrlIfNeeded :: FilePath -> URL -> MVar CheckerWrite -> Checker ()
checkUrlIfNeeded :: String -> String -> MVar CheckerWrite -> Checker ()
checkUrlIfNeeded String
filepath String
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    <- (String
url String -> 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 -> String -> Checker ()
forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.debug Logger
logger String
"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
$ String -> MVar CheckerWrite -> CheckerState -> CheckerState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
url MVar CheckerWrite
m
                String -> String -> Checker ()
checkUrl String
filepath String
url


--------------------------------------------------------------------------------
checkUrl :: FilePath -> URL -> Checker ()
checkUrl :: String -> String -> Checker ()
checkUrl String
filePath String
url
    | String -> Bool
isExternal String
url  = String -> Checker ()
checkExternalUrl String
url
    | String -> Bool
hasProtocol String
url = String -> Maybe String -> Checker ()
skip String
url (Maybe String -> Checker ()) -> Maybe String -> Checker ()
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
"Unknown protocol, skipping"
    | Bool
otherwise       = String -> String -> Checker ()
checkInternalUrl String
filePath String
url
  where
    validProtoChars :: String
validProtoChars = [Char
'A'..Char
'Z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"+-."
    hasProtocol :: String -> Bool
hasProtocol String
str = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') String
str of
        (String
proto, Char
':' : String
_) -> (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
validProtoChars) String
proto
        (String, String)
_                -> Bool
False


--------------------------------------------------------------------------------
ok :: URL -> Checker ()
ok :: String -> Checker ()
ok String
url = String -> CheckerWrite -> Checker ()
putCheckResult String
url CheckerWrite
forall a. Monoid a => a
mempty {checkerOk :: Int
checkerOk = Int
1}


--------------------------------------------------------------------------------
skip :: URL -> Maybe String -> Checker ()
skip :: String -> Maybe String -> Checker ()
skip String
url Maybe String
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 String
maybeReason of
        Maybe String
Nothing     -> () -> Checker ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just String
reason -> Logger -> String -> Checker ()
forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.debug Logger
logger String
reason
    String -> CheckerWrite -> Checker ()
putCheckResult String
url CheckerWrite
forall a. Monoid a => a
mempty {checkerOk :: Int
checkerOk = Int
1}


--------------------------------------------------------------------------------
faulty :: URL -> Maybe String -> Checker ()
faulty :: String -> Maybe String -> Checker ()
faulty String
url Maybe String
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 -> String -> Checker ()
forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.error Logger
logger (String -> Checker ()) -> String -> Checker ()
forall a b. (a -> b) -> a -> b
$ String
"Broken link to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
url String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
explanation
    String -> CheckerWrite -> Checker ()
putCheckResult String
url CheckerWrite
forall a. Monoid a => a
mempty {checkerFaulty :: Int
checkerFaulty = Int
1}
  where
    formatExplanation :: ShowS
formatExplanation = (String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")")
    explanation :: String
explanation = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ShowS
formatExplanation Maybe String
reason


--------------------------------------------------------------------------------
putCheckResult :: URL -> CheckerWrite -> Checker ()
putCheckResult :: String -> CheckerWrite -> Checker ()
putCheckResult String
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 = String -> CheckerState -> Maybe (MVar CheckerWrite)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
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 -> String -> Checker ()
forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.debug Logger
logger String
"Failed to find existing entry for checked URL"


--------------------------------------------------------------------------------
checkInternalUrl :: FilePath -> URL -> Checker ()
checkInternalUrl :: String -> String -> Checker ()
checkInternalUrl String
base String
url = case String
url' of
    String
"" -> String -> Checker ()
ok String
url
    String
_  -> 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 :: String
dest = Configuration -> String
destinationDirectory Configuration
config
            dir :: String
dir  = ShowS
takeDirectory String
base
            filePath :: String
filePath
                | String
"/" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
url' = String
dest String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
url'
                | Bool
otherwise             = String
dir String -> ShowS
</> String
url'

        Bool
exists <- String -> ReaderT CheckerRead (StateT CheckerState IO) Bool
checkFileExists String
filePath
        if Bool
exists then String -> Checker ()
ok String
url else String -> Maybe String -> Checker ()
faulty String
url Maybe String
forall a. Maybe a
Nothing
  where
    url' :: String
url' = ShowS
stripFragments ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
unEscapeString String
url


--------------------------------------------------------------------------------
checkExternalUrl :: URL -> Checker ()
#ifdef CHECK_EXTERNAL
checkExternalUrl :: String -> Checker ()
checkExternalUrl String
url = do
    Either SomeException Bool
result <- String -> Checker (Either SomeException Bool)
requestExternalUrl String
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
_       -> String -> Maybe String -> Checker ()
faulty String
url (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ e -> String
forall a. (Typeable a, Show a) => a -> String
showException e
e)
        Right Bool
_ -> String -> Checker ()
ok String
url
    where
        -- Convert exception to a concise form
        showException :: a -> String
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 -> String
forall a. Show a => a -> String
show HttpExceptionContent
e'
            Maybe HttpException
_                                     -> [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
words (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
e

requestExternalUrl :: URL -> Checker (Either SomeException Bool)
requestExternalUrl :: String -> Checker (Either SomeException Bool)
requestExternalUrl String
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  <- String -> ResourceT IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
Http.parseRequest String
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 = String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"hakyll-check/" String -> ShowS
forall a. [a] -> [a] -> [a]
++
             (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show ([Int] -> [String]) -> [Int] -> [String]
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 :: String -> ReaderT CheckerRead (StateT CheckerState IO) Bool
checkFileExists String
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 <- String -> IO Bool
doesFileExist String
filePath
    Bool
dir  <- String -> IO Bool
doesDirectoryExist String
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) -> String -> IO Bool
doesFileExist (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ String
filePath String -> ShowS
</> String
"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 -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
'?', Char
'#'])