--------------------------------------------------------------------------------
{-# 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
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
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]
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) <- 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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Int
failed 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 = 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 (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 <- forall a. MVar a -> IO a
readMVar MVar CheckerWrite
mvar
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
failures 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]
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 forall a. Num a => a -> a -> a
+ Int
f2) (Int
o1 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 = 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
                    { checkerConfig :: Configuration
checkerConfig = Configuration
config
                    , checkerLogger :: Logger
checkerLogger = Logger
logger
                    , checkerCheck :: Check
checkerCheck  = Check
check'
                    }
    Logger -> IO ()
Logger.flush Logger
logger
    forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Checker a
checker CheckerRead
read') forall k a. Map k a
Map.empty


--------------------------------------------------------------------------------
checkDestination :: Checker ()
checkDestination :: Checker ()
checkDestination = do
    Configuration
config <- CheckerRead -> Configuration
checkerConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    [[Char]]
files  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ([Char] -> IO Bool) -> [Char] -> IO [[Char]]
getRecursiveContents
        (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ 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 forall a. Eq a => a -> a -> Bool
== [Char]
".html"
            ]

    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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    [Char]
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
readFile [Char]
filePath
    forall (m :: * -> *). MonadIO m => Logger -> [Char] -> m ()
Logger.header Logger
logger forall a b. (a -> b) -> a -> b
$ [Char]
"Checking file " forall a. [a] -> [a] -> [a]
++ [Char]
filePath

    let urls :: [[Char]]
urls = [Tag [Char]] -> [[Char]]
getUrls forall a b. (a -> b) -> a -> b
$ forall str. StringLike str => str -> [Tag str]
TS.parseTags [Char]
contents
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
urls forall a b. (a -> b) -> a -> b
$ \[Char]
url -> do
        forall (m :: * -> *). MonadIO m => Logger -> [Char] -> m ()
Logger.debug Logger
logger forall a b. (a -> b) -> a -> b
$ [Char]
"Checking link " forall a. [a] -> [a] -> [a]
++ [Char]
url
        MVar CheckerWrite
m <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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:" forall a. [a] -> [a] -> [a]
++ [Char]
url else [Char]
url
        schemeRelative :: [Char] -> Bool
schemeRelative = 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           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Bool
needsCheck <- (forall a. Eq a => a -> a -> Bool
== Check
All) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckerRead -> Check
checkerCheck forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Bool
checked    <- ([Char]
url forall k a. Ord k => k -> Map k a -> Bool
`Map.member`)      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
    if Bool -> Bool
not Bool
needsCheck Bool -> Bool -> Bool
|| Bool
checked
        then forall (m :: * -> *). MonadIO m => Logger -> [Char] -> m ()
Logger.debug Logger
logger [Char]
"Already checked, skipping"
        else do forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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'] forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9'] forall a. [a] -> [a] -> [a]
++ [Char]
"+-."
    hasProtocol :: [Char] -> Bool
hasProtocol [Char]
str = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
':') [Char]
str of
        ([Char]
proto, Char
':' : [Char]
_) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    case Maybe [Char]
maybeReason of
        Maybe [Char]
Nothing     -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just [Char]
reason -> forall (m :: * -> *). MonadIO m => Logger -> [Char] -> m ()
Logger.debug Logger
logger [Char]
reason
    [Char] -> CheckerWrite -> Checker ()
putCheckResult [Char]
url 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *). MonadIO m => Logger -> [Char] -> m ()
Logger.error Logger
logger forall a b. (a -> b) -> a -> b
$ [Char]
"Broken link to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
url forall a. [a] -> [a] -> [a]
++ [Char]
explanation
    [Char] -> CheckerWrite -> Checker ()
putCheckResult [Char]
url forall a. Monoid a => a
mempty {checkerFaulty :: Int
checkerFaulty = Int
1}
  where
    formatExplanation :: ShowS
formatExplanation = ([Char]
" (" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ [Char]
")")
    explanation :: [Char]
explanation = 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 <- forall s (m :: * -> *). MonadState s m => m s
get
    let maybeMVar :: Maybe (MVar CheckerWrite)
maybeMVar = 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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar CheckerWrite
m CheckerWrite
result
        Maybe (MVar CheckerWrite)
Nothing -> do
            Logger
logger <- CheckerRead -> Logger
checkerLogger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
            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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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]
"/" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
url' = [Char]
dest 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 forall a. Maybe a
Nothing
  where
    url' :: [Char]
url' = ShowS
stripFragments 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 (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e :: Maybe SomeAsyncException) of
                Just SomeAsyncException
ae -> forall a e. Exception e => e -> a
throw SomeAsyncException
ae
                Maybe SomeAsyncException
_       -> [Char] -> Maybe [Char] -> Checker ()
faulty [Char]
url (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
e of
            Just (Http.HttpExceptionRequest Request
_ HttpExceptionContent
e') -> forall a. Show a => a -> [Char]
show HttpExceptionContent
e'
            Maybe HttpException
_                                     -> forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
words forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show a
e

requestExternalUrl :: URL -> Checker (Either SomeException Bool)
requestExternalUrl :: [Char] -> Checker (Either SomeException Bool)
requestExternalUrl [Char]
url = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ do
    Manager
mgr <- ManagerSettings -> IO Manager
Http.newManager ManagerSettings
Http.tlsManagerSettings
    forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT forall a b. (a -> b) -> a -> b
$ do
        Request
request  <- forall (m :: * -> *). MonadThrow m => [Char] -> m Request
Http.parseRequest [Char]
url
        Response (ConduitM Any ByteString (ResourceT IO) ())
response <- 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 (forall body. Response body -> Status
Http.responseStatus Response (ConduitM Any ByteString (ResourceT IO) ())
response)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
code forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
code 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) forall a. a -> [a] -> [a]
: Request -> RequestHeaders
Http.requestHeaders Request
r
            }

        -- Nice user agent info
        ua :: ByteString
ua = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ [Char]
"hakyll-check/" forall a. [a] -> [a] -> [a]
++
             (forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        (Bool
_, Bool
True) -> [Char] -> IO Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ [Char]
filePath [Char] -> ShowS
</> [Char]
"index.html"
        (Bool, Bool)
_         -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False


--------------------------------------------------------------------------------
stripFragments :: String -> String
stripFragments :: ShowS
stripFragments = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
'?', Char
'#'])