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