--------------------------------------------------------------------------------
{-# 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
    ((), 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'
    failed <- countFailedLinks state
    return $ if failed > 0 then ExitFailure 1 else 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 <- MVar CheckerWrite -> IO CheckerWrite
forall a. MVar a -> IO a
readMVar MVar CheckerWrite
mvar
              return $ failures + checkerFaulty 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
    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
    files  <- liftIO $ getRecursiveContents
        (const $ return False) (destinationDirectory config)

    let htmls =
            [ Configuration -> [Char]
destinationDirectory Configuration
config [Char] -> ShowS
</> [Char]
file
            | [Char]
file <- [[Char]]
files
            , Configuration -> [Char] -> Bool
checkHtmlFile Configuration
config [Char]
file
            ]

    forM_ htmls checkFile


--------------------------------------------------------------------------------
checkFile :: FilePath -> Checker ()
checkFile :: [Char] -> Checker ()
checkFile [Char]
filePath = do
    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
    contents <- liftIO $ readFile filePath
    Logger.header logger $ "Checking file " ++ filePath

    let 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
    forM_ urls $ \[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
        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
        checkUrlIfNeeded filePath (canonicalizeUrl url) 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     <- 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
    needsCheck <- (== All) . checkerCheck <$> ask
    checked    <- (url `Map.member`)      <$> get
    if not needsCheck || checked
        then Logger.debug logger "Already checked, skipping"
        else do modify $ Map.insert url m
                checkUrl filepath 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 <- 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 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
    putCheckResult url mempty {checkerOk = 1}


--------------------------------------------------------------------------------
faulty :: URL -> Maybe String -> Checker ()
faulty :: [Char] -> Maybe [Char] -> Checker ()
faulty [Char]
url Maybe [Char]
reason = do
    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.error logger $ "Broken link to " ++ show url ++ explanation
    putCheckResult url 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
    state <- ReaderT CheckerRead (StateT CheckerState IO) CheckerState
forall s (m :: * -> *). MonadState s m => m s
get
    let maybeMVar = [Char] -> CheckerState -> Maybe (MVar CheckerWrite)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
url CheckerState
state
    case 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 <- 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.debug logger "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
        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 = Configuration -> [Char]
destinationDirectory Configuration
config
            dir  = ShowS
takeDirectory [Char]
base
            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'

        exists <- checkFileExists filePath
        if exists then ok url else faulty url 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
    result <- [Char] -> Checker (Either SomeException Bool)
requestExternalUrl [Char]
url
    case 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. (HasCallStack, 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
    mgr <- ManagerSettings -> IO Manager
Http.newManager ManagerSettings
Http.tlsManagerSettings
    runResourceT $ do
        request  <- Http.parseRequest url
        response <- Http.http (settings request) mgr
        let code = Status -> Int
Http.statusCode (Response (ConduitM (ZonkAny 0) ByteString (ResourceT IO) ())
-> Status
forall body. Response body -> Status
Http.responseStatus Response (ConduitM (ZonkAny 0) ByteString (ResourceT IO) ())
response)
        -- Recall that 3XX status codes are redirections, which aren't necessarily errors. 
        return $ code >= 200 && code < 400
    where
        -- Add additional request info
        settings :: Request -> Request
settings Request
r = Request
r
            { Http.method         = "HEAD"
            , Http.redirectCount  = 10
            , Http.requestHeaders = ("User-Agent", ua) : Http.requestHeaders r
            }

        -- Nice user agent info
        ua :: ByteString
ua = [Char] -> ByteString
forall a. IsString a => [Char] -> a
fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"hakyll-check/" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
             ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
forall a. Show a => a -> [Char]
show ([Int] -> [[Char]]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Version -> [Int]
versionBranch Version
Paths_hakyll.version)
#else
checkExternalUrl url = skip url Nothing
#endif


--------------------------------------------------------------------------------
-- | Wraps doesFileExist, also checks for index.html
checkFileExists :: FilePath -> Checker Bool
checkFileExists :: [Char] -> ReaderT CheckerRead (StateT CheckerState IO) Bool
checkFileExists [Char]
filePath = IO Bool -> ReaderT CheckerRead (StateT CheckerState IO) Bool
forall a. IO a -> ReaderT CheckerRead (StateT CheckerState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ReaderT CheckerRead (StateT CheckerState IO) Bool)
-> IO Bool -> ReaderT CheckerRead (StateT CheckerState IO) Bool
forall a b. (a -> b) -> a -> b
$ do
    file <- [Char] -> IO Bool
doesFileExist [Char]
filePath
    dir  <- doesDirectoryExist filePath
    case (file, 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
'#'])