From 58e0d3f35668898a9d3a96085fcc19cc9a66757b Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <m@jaspervdj.be>
Date: Sat, 29 Dec 2012 17:49:11 +0100
Subject: Draft external URL checker

---
 src/Hakyll/Check.hs | 43 ++++++++++++++++++++++++++++++++++---------
 1 file changed, 34 insertions(+), 9 deletions(-)

(limited to 'src/Hakyll')

diff --git a/src/Hakyll/Check.hs b/src/Hakyll/Check.hs
index 3728235..27e7c50 100644
--- a/src/Hakyll/Check.hs
+++ b/src/Hakyll/Check.hs
@@ -6,12 +6,15 @@ module Hakyll.Check
 
 --------------------------------------------------------------------------------
 import           Control.Applicative       ((<$>))
+import           Control.Exception         (SomeException, handle)
 import           Control.Monad             (forM_)
 import           Control.Monad.Reader      (ReaderT, ask, runReaderT)
 import           Control.Monad.Trans       (liftIO)
 import           Control.Monad.Writer      (WriterT, runWriterT, tell)
 import           Data.List                 (isPrefixOf)
 import           Data.Monoid               (Monoid (..))
+import qualified Network.HTTP.Conduit      as Http
+import qualified Network.HTTP.Types        as Http
 import           System.Directory          (doesDirectoryExist, doesFileExist)
 import           System.FilePath           (takeDirectory, takeExtension, (</>))
 import qualified Text.HTML.TagSoup         as TS
@@ -89,14 +92,25 @@ checkFile filePath = do
             else checkInternalUrl filePath url
 
 
+--------------------------------------------------------------------------------
+ok :: String -> Checker ()
+ok _ = tell $ mempty {checkerOk = 1}
+
+
+--------------------------------------------------------------------------------
+faulty :: String -> Checker ()
+faulty url = do
+    logger <- checkerLogger <$> ask
+    Logger.error logger $ "Broken link to " ++ show url
+    tell $ mempty {checkerFaulty = 1}
+
+
 --------------------------------------------------------------------------------
 checkInternalUrl :: FilePath -> String -> Checker ()
 checkInternalUrl base url = case url' of
-    "" -> tell $ mempty {checkerOk = 1}
+    "" -> ok url
     _  -> do
-        logger <- checkerLogger <$> ask
         config <- checkerConfig <$> ask
-
         let dest = destinationDirectory config
             dir  = takeDirectory base
             filePath
@@ -104,11 +118,7 @@ checkInternalUrl base url = case url' of
                 | otherwise             = dir </> url'
 
         exists <- checkFileExists filePath
-        if exists
-            then tell $ mempty {checkerOk = 1}
-            else do
-                tell $ mempty {checkerFaulty = 1}
-                Logger.error logger $ base ++ ": broken link to " ++ show url
+        if exists then ok url else faulty url
   where
     url' = stripFragments url
 
@@ -118,7 +128,22 @@ checkExternalUrl :: String -> Checker ()
 checkExternalUrl url = do
     logger <- checkerLogger <$> ask
     Logger.message logger $ "Not checking external url " ++ url
-    -- TODO: use http-conduit and a cache?
+
+    isOk <- liftIO $ handle failure $ Http.withManager $ \manager -> do
+        request  <- Http.parseUrl url
+        response <- Http.http (settings request) manager
+        let code = Http.statusCode (Http.responseStatus response)
+        return $ code >= 200 && code < 300
+
+    if isOk then ok url else faulty url
+  where
+    settings r = r
+        { Http.redirectCount   = 10
+        , Http.responseTimeout = Just 10
+        }
+
+    failure :: SomeException -> IO Bool
+    failure e = print e >> return False
 
 
 --------------------------------------------------------------------------------
-- 
cgit v1.2.3