Allow checking internal links only

3 files changed, 30 insertions, 16 deletions

diff --git a/src/Hakyll/Check.hs b/src/Hakyll/Check.hs
index 5908310..6b9918b 100644
--- a/src/Hakyll/Check.hs
+++ b/src/Hakyll/Check.hs
@@ -1,7 +1,8 @@
 --------------------------------------------------------------------------------
 {-# LANGUAGE OverloadedStrings #-}
 module Hakyll.Check
-    ( check
+    ( Check (..)
+    , check
     ) where
 
 
@@ -37,9 +38,14 @@ import           Hakyll.Web.Html
 
 
 --------------------------------------------------------------------------------
-check :: Configuration -> Verbosity -> IO ExitCode
-check config verbosity = do
-    ((), write) <- runChecker checkDestination config verbosity
+data Check = All | InternalLinks
+    deriving (Eq, Ord, Show)
+
+
+--------------------------------------------------------------------------------
+check :: Configuration -> Verbosity -> Check -> IO ExitCode
+check config verbosity check' = do
+    ((), write) <- runChecker checkDestination config verbosity check'
     return $ if checkerFaulty write >= 0 then ExitFailure 1 else ExitSuccess
 
 
@@ -47,6 +53,7 @@ check config verbosity = do
 data CheckerRead = CheckerRead
     { checkerConfig :: Configuration
     , checkerLogger :: Logger
+    , checkerCheck  :: Check
     }
 
 
@@ -73,10 +80,11 @@ type Checker a = RWST CheckerRead CheckerWrite CheckerState IO a
 
 
 --------------------------------------------------------------------------------
-runChecker :: Checker a -> Configuration -> Verbosity -> IO (a, CheckerWrite)
-runChecker checker config verbosity = do
+runChecker :: Checker a -> Configuration -> Verbosity -> Check
+           -> IO (a, CheckerWrite)
+runChecker checker config verbosity check' = do
     logger <- Logger.new verbosity
-    let read' = CheckerRead config logger
+    let read' = CheckerRead config logger check'
     (x, _, write) <- runRWST checker read' S.empty
     Logger.flush logger
     return (x, write)
@@ -146,10 +154,11 @@ checkInternalUrl base url = case url' of
 --------------------------------------------------------------------------------
 checkExternalUrl :: String -> Checker ()
 checkExternalUrl url = do
-    logger  <- checkerLogger    <$> ask
-    checked <- (url `S.member`) <$> get
+    logger     <- checkerLogger           <$> ask
+    needsCheck <- (== All) . checkerCheck <$> ask
+    checked    <- (url `S.member`)        <$> get
 
-    if checked
+    if not needsCheck || checked
         then Logger.debug logger "Already checked, skipping"
         else do
             isOk <- liftIO $ handle (failure logger) $
diff --git a/src/Hakyll/Commands.hs b/src/Hakyll/Commands.hs
index 23deb7f..b7e85bc 100644
--- a/src/Hakyll/Commands.hs
+++ b/src/Hakyll/Commands.hs
@@ -49,8 +49,8 @@ build conf verbosity rules = do
 
 --------------------------------------------------------------------------------
 -- | Run the checker and exit
-check :: Configuration -> Verbosity -> IO ()
-check config verbosity = Check.check config verbosity >>= exitWith
+check :: Configuration -> Verbosity -> Check.Check -> IO ()
+check config verbosity check' = Check.check config verbosity check' >>= exitWith
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs
index 86aae28..527548d 100644
--- a/src/Hakyll/Main.hs
+++ b/src/Hakyll/Main.hs
@@ -16,7 +16,8 @@ import           System.IO.Unsafe                (unsafePerformIO)
 
 
 --------------------------------------------------------------------------------
-import qualified          Hakyll.Commands as Commands
+import qualified Hakyll.Check                    as Check
+import qualified Hakyll.Commands                 as Commands
 import qualified Hakyll.Core.Configuration       as Config
 import qualified Hakyll.Core.Logger              as Logger
 import           Hakyll.Core.Rules
@@ -36,9 +37,12 @@ hakyllWith conf rules = do
     args' <- cmdArgs hakyllArgs
 
     let verbosity' = if verbose args' then Logger.Debug else Logger.Message
+        check'     =
+            if internal_links args' then Check.InternalLinks else Check.All
+
     case args' of
         Build   _   -> Commands.build conf verbosity' rules
-        Check   _   -> Commands.check conf verbosity'
+        Check   _ _ -> Commands.check conf verbosity' check'
         Clean   _   -> Commands.clean conf
         Deploy  _   -> Commands.deploy conf
         Help    _   -> showHelp
@@ -56,7 +60,7 @@ showHelp = print $ CA.helpText [] CA.HelpFormatOne $ cmdArgsMode hakyllArgs
 --------------------------------------------------------------------------------
 data HakyllArgs
     = Build   {verbose :: Bool}
-    | Check   {verbose :: Bool}
+    | Check   {verbose :: Bool, internal_links :: Bool}
     | Clean   {verbose :: Bool}
     | Deploy  {verbose :: Bool}
     | Help    {verbose :: Bool}
@@ -70,7 +74,8 @@ data HakyllArgs
 hakyllArgs :: HakyllArgs
 hakyllArgs = modes
     [ (Build $ verboseFlag def) &= help "Generate the site"
-    , (Check $ verboseFlag def) &= help "Validate the site output"
+    , (Check (verboseFlag def) (False &= help "Check internal links only")) &=
+        help "Validate the site output"
     , (Clean $ verboseFlag def) &= help "Clean up and remove cache"
     , (Deploy $ verboseFlag def) &= help "Upload/deploy your site"
     , (Help $ verboseFlag def) &= help "Show this message" &= auto