1 {-# LANGUAGE FlexibleContexts #-}
    2 {-# LANGUAGE ConstraintKinds #-}
    3 {-# LANGUAGE DeriveGeneric #-}
    4 {-# LANGUAGE OverloadedStrings #-}
    5 
    6 import Test.Hspec
    7 -- import Test.QuickCheck
    8 import System.Process
    9 import System.Exit
   10 import System.Directory (getCurrentDirectory, setCurrentDirectory, getDirectoryContents, doesDirectoryExist, removeDirectoryRecursive, createDirectoryIfMissing, isSymbolicLink)
   11 import Control.Monad
   12 import GHC.Generics
   13 import Data.Yaml
   14 import System.FilePath
   15 import System.Posix.Files (createSymbolicLink, fileExist)
   16 
   17 data AutoTest = AutoTest { description :: String, ttype :: String, tstderr :: String } deriving (Ord, Eq, Show, Generic)
   18 
   19 instance FromJSON AutoTest where
   20   parseJSON (Object v) =
   21     AutoTest <$>
   22     v .:   "description"                        <*>
   23     v .:?  "type"              .!= "success"   <*>
   24     v .:?  "stderr"             .!= ""
   25   parseJSON _ = fail "Failed to parse in AutoTest"
   26 
   27 -- Run a command and consider a good exit value a success; the
   28 -- reason this is worth its own function is that we have to make
   29 -- sure we fail in the right way, or we get the output as a
   30 -- "foo\nbar\n" sort of string.
   31 runCmd :: AutoTest -> String -> [String] -> String -> Bool -> IO ()
   32 runCmd autoTest cmd args stdin shouldFail = do
   33   (exit, stdout, stderr) <- readProcessWithExitCode cmd args stdin
   34   if shouldFail then
   35     do
   36       exit `shouldNotBe` ExitSuccess
   37       (stdout ++ stderr) `shouldContain` (tstderr autoTest)
   38       -- (stderr =~ (compile (pack (tstderr autoTest)) [])) `shouldBe` True
   39   else
   40     if exit /= ExitSuccess then
   41       -- Gives us the properly formatted output
   42       expectationFailure $ 
   43         "stdout: \n\n" ++ stdout ++
   44         "\n\nstderr: \n\n" ++ stderr
   45     else
   46       exit `shouldBe` ExitSuccess
   47 
   48 hblogRunCmd :: Bool -> AutoTest -> FilePath -> FilePath -> String -> [String] -> IO ()
   49 hblogRunCmd shouldFail autoTest appDir mainDir cmd args = do
   50   setCurrentDirectory appDir
   51   (exit, stdout, stderr) <- readProcessWithExitCode cmd args ""
   52   setCurrentDirectory mainDir
   53   if shouldFail then
   54     do
   55       exit `shouldNotBe` ExitSuccess
   56       (stdout ++ stderr) `shouldContain` (tstderr autoTest)
   57       -- (stderr =~ (compile (pack (tstderr autoTest)) [])) `shouldBe` True
   58   else
   59     if exit /= ExitSuccess then
   60       -- Gives us the properly formatted output
   61       expectationFailure $ 
   62         "stdout: \n\n" ++ stdout ++
   63         "\n\nstderr: \n\n" ++ stderr
   64     else
   65       exit `shouldBe` ExitSuccess
   66 
   67 rm_rf :: FilePath -> IO ()
   68 rm_rf dir = do
   69   exists <- doesDirectoryExist dir
   70   if exists then
   71     removeDirectoryRecursive dir
   72   else
   73     return ()
   74 
   75 hblogTest :: Bool -> AutoTest -> FilePath -> SpecWith ()
   76 hblogTest shouldFail autoTest dir = it (description autoTest) $ do
   77   mainDir <- getCurrentDirectory
   78   rm_rf $ dir </> "_site"
   79   rm_rf $ dir </> "_cache"
   80   rm_rf $ dir </> "templates"
   81   callProcess "cp" ["-pr", (mainDir </> "templates"), (dir </> "templates")]
   82 
   83   hblogRunCmd shouldFail autoTest dir mainDir "hblog" ["build"]
   84 
   85   rm_rf $ dir </> "_cache"
   86   rm_rf $ dir </> "templates"
   87 
   88   if (ttype autoTest) == "hblog" then
   89     do
   90       hblogRunCmd shouldFail autoTest dir mainDir "diff" ["-r", (mainDir </> dir </> "wanted"), (mainDir </> dir </> "_site")]
   91   else
   92     return ()
   93 
   94 pathKids :: Bool -> FilePath -> IO [FilePath]
   95 pathKids full dir = do
   96   namesAll <- getDirectoryContents dir
   97   let realNames = filter (\x -> x /= "." && x /= "..") namesAll
   98   if full then
   99     let fullNames = map (dir </>) realNames in
  100       return fullNames
  101   else
  102     return realNames
  103 
  104 genTest :: String -> AutoTest -> FilePath -> SpecWith ()
  105 genTest prog autoTest dir = it (description autoTest) $ do
  106   let indir = dir </> "in"
  107   let outdir = dir </> "out"
  108   let wanteddir = dir </> "wanted"
  109   outExists <- doesDirectoryExist outdir
  110   if outExists then
  111     do _ <- removeDirectoryRecursive outdir
  112        return ()
  113   else
  114     do return ()
  115   _ <- createDirectoryIfMissing True outdir
  116   if (ttype autoTest) == "failure" then
  117     runCmd autoTest prog [indir, outdir] "" True
  118   else
  119     do
  120       runCmd autoTest prog [indir, outdir] "" False
  121       runCmd autoTest "diff" ["-r", wanteddir, outdir] "" False
  122 
  123 genDirTests :: String -> FilePath -> Spec
  124 genDirTests prog dir = do
  125   eitherAutoTest <- runIO $ (decodeFileEither (dir </> "config.yaml") :: IO (Either ParseException AutoTest))
  126   case eitherAutoTest of
  127     Left parseBad -> error $ "\n\nYAML parse fail on config.yaml in " ++ dir ++ " with error " ++ (show parseBad) ++ "\n\n"
  128     Right autoTest -> if (ttype autoTest) == "hblog" then
  129                         hblogTest False autoTest dir
  130                       else
  131                         if (ttype autoTest) == "hblog-fail" then 
  132                           hblogTest True autoTest dir
  133                         else
  134                           genTest prog autoTest dir
  135 
  136 genProgDirTests :: FilePath -> Spec
  137 genProgDirTests prog = do
  138   dirNames <- runIO $ pathKids True ("tests" </> prog)
  139   forM_ dirNames $ genDirTests prog
  140 
  141 genProgTests :: FilePath -> Spec
  142 genProgTests prog = do
  143   describe ("the " ++ prog ++ " program") $ genProgDirTests prog
  144 
  145 main :: IO ()
  146 main = do
  147   dirNames <- pathKids False "tests"
  148   hspec $ do
  149     forM_ dirNames $ genProgTests