CrawlingTests.hs

module Main (main) where

import Data.Maybe (listToMaybe)
import System.Exit (exitFailure)

import Network.CrawlChain.CrawlingContext
import Network.CrawlChain.CrawlAction
import Network.CrawlChain.CrawlChain
import Network.CrawlChain.CrawlDirective
import Network.CrawlChain.DirectiveChainResult
import Text.HTML.CrawlChain.HtmlFiltering

testResourcePath :: String
testResourcePath = "test/resources"

-- I really would like to use the detailed test-suite, but that seems to be still unsupported albeit years have passed.
main :: IO ()
main = do
    doTest "basicTest" basicTestChain "expected.html"
  where
    basicTestChain =
      (GetRequest "http://first.html",
       SimpleDirective extractLinks)

doTest :: String -> (CrawlAction, CrawlDirective) -> String -> IO ()
doTest testname template expectedUrl = do
  results <- uncurry (executeCrawlChain testingContext) template
  checkFirstResult results expectedUrl
  where
    testingContext = readingContext $ testResourcePath ++ "/" ++ testname

checkFirstResult :: [DirectiveChainResult] -> String -> IO ()
checkFirstResult rps expected =
  if maybe False (== expected) foundUrl
  then putStrLn $ "\nSuccessfully checked " ++ msg 
  else putStrLn ("\nFailed to check " ++ msg ++ ", found: " ++ (show foundUrl)
                 ++ " in:\n\n" ++ (maybe "" (show . resultHistory) (listToMaybe rps))) >> exitFailure
  where
    foundUrl = extractFirstResult rps >>= return . crawlUrl
    msg = ": " ++ expected