--------------------------------------------------------------------------------
module Hakyll.Check
    ( runCheck
    ) where


--------------------------------------------------------------------------------
import           Control.Applicative       ((<$>))
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           System.Directory          (doesDirectoryExist, doesFileExist)
import           System.FilePath           (takeDirectory, takeExtension, (</>))
import qualified Text.HTML.TagSoup         as TS


--------------------------------------------------------------------------------
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 CheckerRead = CheckerRead
    { checkerConfig :: Configuration
    , checkerLogger :: Logger
    }


--------------------------------------------------------------------------------
data CheckerWrite = CheckerWrite
    { checkerFaulty :: Int
    , checkerOk     :: Int
    } deriving (Show)


--------------------------------------------------------------------------------
instance Monoid CheckerWrite where
    mempty                                            = CheckerWrite 0 0
    mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) =
        CheckerWrite (f1 + f2) (o1 + o2)


--------------------------------------------------------------------------------
type Checker a = ReaderT CheckerRead (WriterT CheckerWrite IO) a


--------------------------------------------------------------------------------
runCheck :: Configuration -> IO ()
runCheck config = do
    logger <- Logger.new (verbosity config)
    let read' = CheckerRead config logger
    ((), write) <- runWriterT $ runReaderT check read'
    Logger.header logger $ show write
    Logger.flush logger


--------------------------------------------------------------------------------
check :: Checker ()
check = do
    config <- checkerConfig <$> ask
    files  <- liftIO $ getRecursiveContents (destinationDirectory config)

    let htmls =
            [ destinationDirectory config </> file
            | file <- files
            , takeExtension file == ".html"
            ]

    forM_ htmls checkFile


--------------------------------------------------------------------------------
checkFile :: FilePath -> Checker ()
checkFile filePath = do
    logger   <- checkerLogger <$> ask
    contents <- liftIO $ readFile filePath
    Logger.header logger $ "Checking " ++ filePath

    let urls = getUrls $ TS.parseTags contents
    forM_ urls $ \url ->
        if isExternal url
            then checkExternalUrl url
            else checkInternalUrl filePath url


--------------------------------------------------------------------------------
checkInternalUrl :: FilePath -> String -> Checker ()
checkInternalUrl base url = case url' of
    "" -> tell $ mempty {checkerOk = 1}
    _  -> do
        logger <- checkerLogger <$> ask
        config <- checkerConfig <$> ask

        let dest = destinationDirectory config
            dir  = takeDirectory base
            filePath
                | "/" `isPrefixOf` url' = dest ++ url'
                | 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
  where
    url' = stripFragments url


--------------------------------------------------------------------------------
checkExternalUrl :: String -> Checker ()
checkExternalUrl url = do
    logger <- checkerLogger <$> ask
    Logger.message logger $ "Not checking external url " ++ url
    -- TODO: use http-conduit and a cache?


--------------------------------------------------------------------------------
-- | Wraps doesFileExist, also checks for index.html
checkFileExists :: FilePath -> Checker Bool
checkFileExists filePath = liftIO $ do
    file <- doesFileExist filePath
    dir  <- doesDirectoryExist filePath
    case (file, dir) of
        (True, _) -> return True
        (_, True) -> doesFileExist $ filePath </> "index.html"
        _         -> return False


--------------------------------------------------------------------------------
stripFragments :: String -> String
stripFragments = takeWhile (not . flip elem ['?', '#'])