{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module Test.Errors(main) where import Development.Shake import Development.Shake.Classes import Development.Shake.FilePath import Test.Type import Data.List import Control.Monad import Control.Concurrent import General.GetOpt import General.Extra import Control.Exception.Extra import System.Directory as IO import System.Time.Extra import qualified System.IO.Extra as IO import Data.Functor import Prelude data Args = Die deriving (Eq,Enum,Bounded,Show) newtype BadBinary = BadBinary String deriving (NFData,Show,Eq,Hashable,Typeable) type instance RuleResult BadBinary = BadBinary instance Binary BadBinary where put (BadBinary x) = put x get = do x <- get; if x == "bad" then error "get: BadBinary \"bad\"" else return $ BadBinary x main = shakeTest test optionsEnum $ \args -> do "norule" %> \_ -> need ["norule_isavailable"] "failcreate" %> \_ -> return () ["failcreates", "failcreates2"] &%> \_ -> writeFile' "failcreates" "" "recursive_" %> \out -> need ["intermediate_"] "intermediate_" %> \out -> need ["recursive_"] "rec1" %> \out -> need ["rec2"] "rec2" %> \out -> need ["rec1"] "systemcmd" %> \_ -> cmd "random_missing_command" "stack1" %> \_ -> need ["stack2"] "stack2" %> \_ -> need ["stack3"] "stack3" %> \_ -> error "crash" "staunch1" %> \out -> do liftIO $ sleep 0.1 writeFile' out "test" "staunch2" %> \_ -> error "crash" let catcher out op = out %> \out -> do writeFile' out "0" op $ do src <- IO.readFile' out; writeFile out $ show (read src + 1 :: Int) catcher "finally1" $ actionFinally $ fail "die" catcher "finally2" $ actionFinally $ return () catcher "finally3" $ actionFinally $ liftIO $ sleep 10 catcher "finally4" $ actionFinally $ need ["wait"] "wait" ~> do liftIO $ sleep 10 catcher "exception1" $ actionOnException $ fail "die" catcher "exception2" $ actionOnException $ return () res <- newResource "resource_name" 1 "resource" %> \out -> withResource res 1 $ need ["resource-dep"] "overlap.txt" %> \out -> writeFile' out "overlap.txt" "overlap.t*" %> \out -> writeFile' out "overlap.t*" "overlap.*" %> \out -> writeFile' out "overlap.*" "chain.2" %> \out -> do src <- readFile' "chain.1" if src == "err" then error "err_chain" else writeFileChanged out src "chain.3" %> \out -> copyFile' "chain.2" out "tempfile" %> \out -> do file <- withTempFile $ \file -> do liftIO $ assertExists file return file liftIO $ assertMissing file withTempFile $ \file -> do liftIO $ assertExists file writeFile' out file fail "tempfile-died" "tempdir" %> \out -> do file <- withTempDir $ \dir -> do let file = dir "foo.txt" liftIO $ writeFile (dir "foo.txt") "" -- will throw if the directory does not exist writeFile' out "" return file liftIO $ assertMissing file phony "fail1" $ fail "die1" phony "fail2" $ fail "die2" when (Die `elem` args) $ action $ error "death error" "fresh_dir" %> \out -> liftIO $ createDirectoryRecursive out "need_dir" %> \out -> do liftIO $ createDirectoryRecursive "existing_dir" need ["existing_dir"] writeFile' out "" "persist_failure.1" %> \out -> do liftIO $ appendFile "persist_failure.log" "[pre]" need ["persist_failure.2"] liftIO $ appendFile "persist_failure.log" "[post]" writeFile' out "" "persist_failure.2" %> \out -> do src <- readFile' "persist_failure.3" liftIO $ print ("persist_failure.3", src) if src == "die" then do liftIO $ appendFile "persist_failure.log" "[err]" fail "die" else writeFileChanged out src "fast_failure" %> \out -> do liftIO $ sleep 0.1 fail "die" "slow_success" %> \out -> do liftIO $ sleep 20 writeFile' out "" addOracle $ \(BadBinary x) -> return $ BadBinary $ 'b':x "badinput" %> \out -> do askOracle $ BadBinary "bad" liftIO $ appendFile out "x" "badoutput" %> \out -> do askOracle $ BadBinary "ad" liftIO $ appendFile out "x" "badnone" %> \out -> do alwaysRerun liftIO $ appendFile out "x" -- not tested by default since only causes an error when idle GC is turned on phony "block" $ liftIO $ putStrLn $ let x = x in x test build = do let crash args parts = assertException parts (build $ "--quiet" : args) build ["clean","--sleep"] writeFile "chain.1" "x" build ["chain.3","--sleep"] writeFile "chain.1" "err" crash ["chain.3"] ["err_chain"] crash ["norule"] ["norule_isavailable"] crash ["failcreate"] ["failcreate"] crash ["failcreates"] ["failcreates"] crash ["recursive_"] ["recursive_","intermediate_","recursive"] crash ["rec1","rec2"] ["rec1","rec2","recursive"] crash ["systemcmd"] ["systemcmd","random_missing_command"] crash ["stack1"] ["stack1","stack2","stack3","crash"] b <- IO.doesFileExist "staunch1" when b $ removeFile "staunch1" crash ["staunch1","staunch2","-j2"] ["crash"] assertBoolIO (not <$> IO.doesFileExist "staunch1") "File should not exist, should have crashed first" crash ["staunch1","staunch2","-j2","--keep-going","--silent"] ["crash"] assertBoolIO (IO.doesFileExist "staunch1") "File should exist, staunch should have let it be created" crash ["finally1"] ["die"] assertContents "finally1" "1" build ["finally2"] assertContents "finally2" "1" crash ["exception1"] ["die"] assertContents "exception1" "1" build ["exception2"] assertContents "exception2" "0" forM_ ["finally3","finally4"] $ \name -> do t <- forkIO $ ignore $ build [name,"--exception"] retry 10 $ sleep 0.1 >> assertContents name "0" throwTo t (IndexOutOfBounds "test") retry 10 $ sleep 0.1 >> assertContents name "1" crash ["resource"] ["cannot currently call apply","withResource","resource_name"] build ["overlap.foo"] assertContents "overlap.foo" "overlap.*" build ["overlap.txt"] assertContents "overlap.txt" "overlap.txt" crash ["overlap.txx"] ["key matches multiple rules","2","overlap.txx"] crash ["tempfile"] ["tempfile-died"] src <- readFile "tempfile" assertMissing src build ["tempdir"] crash ["--die"] ["Shake","action","death error"] putStrLn "## BUILD errors" (out,_) <- IO.captureOutput $ build [] assertBool ("nothing to do" `isInfixOf` out) $ "Expected 'nothing to do', but got: " ++ out putStrLn "## BUILD errors fail1 fail2 -k -j2" (out,_) <- IO.captureOutput $ try_ $ build ["fail1","fail2","-k","-j2",""] assertBool ("die1" `isInfixOf` out && "die2" `isInfixOf` out) $ "Expected 'die1' and 'die2', but got: " ++ out crash ["fresh_dir"] ["expected a file, got a directory","fresh_dir"] crash ["need_dir"] ["expected a file, got a directory","existing_dir"] -- check errors don't persist to the database, #428 writeFile "persist_failure.log" "" writeFile "persist_failure.3" "test" build ["persist_failure.1","--sleep"] writeFile "persist_failure.3" "die" crash ["persist_failure.1","--sleep"] [] assertContents "persist_failure.log" "[pre][post][err][pre]" writeFile "persist_failure.3" "test" build ["persist_failure.1","--sleep"] assertContents "persist_failure.log" "[pre][post][err][pre]" writeFile "persist_failure.3" "more" build ["persist_failure.1"] assertContents "persist_failure.log" "[pre][post][err][pre][pre][post]" -- check a fast failure aborts a slow success (t, _) <- duration $ crash ["fast_failure","slow_success","-j2"] ["die"] assertBool (t < 10) $ "Took too long, expected < 10, got " ++ show t -- for exceptions on Key we die while reading the database, and restart from scratch build ["badinput"] build ["badinput","--silent"] assertContents "badinput" "xx" build ["badnone","--silent"] -- must be able to still run other rules assertContents "badnone" "x" -- for exceptions on Value we die while running the rule that requires it build ["badoutput"] crash ["badoutput"] ["badoutput","BadBinary"] build ["badnone"] -- must be able to still run other rules assertContents "badnone" "xx"