Skip to content
Browse files

Initial version!

  • Loading branch information...
0 parents commit 0ffa89c84b068bbedeab64fbd9292824543bcfe7 @acw committed Dec 27, 2011
Showing with 151 additions and 0 deletions.
  1. +1 −0 .gitignore
  2. +27 −0 LICENSE
  3. +100 −0 Test/Framework/Providers/Program.hs
  4. +23 −0 test-framework-program.cabal
1 .gitignore
@@ -0,0 +1 @@
+dist/
27 LICENSE
@@ -0,0 +1,27 @@
+Copyright (c) 2011, Adam Wick
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distributiona
+
+ * Neither the name of Adam Wick nor the names of other contributors may be
+ used to endorse or promote products derived from this software without
+ specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
100 Test/Framework/Providers/Program.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Test.Framework.Providers.Program(
+ Checker
+ , testProgramRuns
+ , testProgramOutput
+ )
+ where
+
+import System.Directory
+import System.Exit
+import System.IO hiding (stdout, stderr)
+import System.Process hiding (runProcess)
+
+import Test.Framework.Providers.API
+
+-- |A shorthand for a possible function checking an output stream.
+type Checker = Maybe (String -> Bool)
+
+runCheck :: Checker -> String -> Bool
+runCheck Nothing _ = True
+runCheck (Just f) x = f x
+
+data TestCaseResult = Passed | ProgramFailed ExitCode |
+ Timeout | CheckFailed |
+ NotExecutable
+data TestCaseRunning = CheckExists | CheckRunnable | Running
+data TestCase = TestCase Checker Checker FilePath [FilePath]
+
+instance Show TestCaseResult where
+ show Passed = "OK"
+ show (ProgramFailed c) = "Program failed: Exit code " ++ show c
+ show Timeout = "Test timed out."
+ show CheckFailed = "Post-run check failed"
+ show NotExecutable = "Program not found / executable."
+instance Show TestCaseRunning where
+ show CheckExists = "Checking program existence"
+ show CheckRunnable = "Checking program is executable"
+ show Running = "Running"
+
+instance TestResultlike TestCaseRunning TestCaseResult where
+ testSucceeded x = case x of
+ Passed -> True
+ _ -> False
+
+instance Testlike TestCaseRunning TestCaseResult TestCase where
+ testTypeName _ = "Executable program test."
+ runTest topts (TestCase outCheck errCheck prog args) = runImprovingIO $ do
+ yieldImprovement CheckExists
+ exists <- liftIO $ doesFileExist prog
+ if exists
+ then do yieldImprovement CheckRunnable
+ perms <- liftIO $ getPermissions prog
+ if executable perms
+ then do yieldImprovement Running
+ runProgram topts outCheck errCheck prog args
+ else return NotExecutable
+ else return NotExecutable
+
+runProgram :: TestOptions' K->
+ Checker -> Checker ->
+ FilePath -> [String] ->
+ ImprovingIO i f TestCaseResult
+runProgram topts stdoutCheck stderrCheck prog args = do
+ let timeout = unK (topt_timeout topts)
+ mres <- maybeTimeoutImprovingIO timeout $ liftIO $ runProcess prog args
+ case mres of
+ Nothing -> return Timeout
+ Just (ExitSuccess, stdout, stderr)
+ | runCheck stdoutCheck stdout && runCheck stderrCheck stderr ->
+ return Passed
+ | otherwise ->
+ return CheckFailed
+ Just (x, _, _) ->
+ return (ProgramFailed x)
+
+runProcess :: FilePath -> [String] -> IO (ExitCode, String, String)
+runProcess prog args = do
+ (_,o,e,p) <- runInteractiveProcess prog args Nothing Nothing
+ hSetBuffering o NoBuffering
+ hSetBuffering e NoBuffering
+ sout <- hGetContents o
+ serr <- hGetContents e
+ ecode <- length sout `seq` waitForProcess p
+ return (ecode, sout, serr)
+
+-- |Test that a given program runs correctly with the given arguments. 'Runs
+-- correctly' is defined as running and exiting with a successful (0) error
+-- code.
+testProgramRuns :: String -> FilePath -> [String] -> Test
+testProgramRuns name prog args =
+ testProgramOutput name prog args Nothing Nothing
+
+-- |Test that a given program runs correctly (exits successfully), and that
+-- its stdout / stderr are acceptable.
+testProgramOutput :: String -> FilePath -> [String] ->
+ Checker -> Checker ->
+ Test
+testProgramOutput name prog args soutCheck serrCheck =
+ Test name (TestCase soutCheck serrCheck prog args)
+
23 test-framework-program.cabal
@@ -0,0 +1,23 @@
+Name: test-framework-program
+Version: 1.0
+Cabal-Version: >= 1.6
+Category: Testing
+Synopsis: Test framework support for running simple test programs.
+License: BSD3
+License-File: LICENSE
+Author: Adam Wick <awick@uhsure.com>
+Maintainer: Adam Wick <awick@uhsure.com>
+Build-Type: Simple
+
+Library
+ Exposed-Modules: Test.Framework.Providers.Program
+ Build-Depends: base >= 3 && <= 6,
+ directory >= 1 && <= 2,
+ process >= 1.1 && <= 2,
+ test-framework >= 0.2.0 && < 0.5.0
+ Extensions: MultiParamTypeClasses
+ Ghc-Options: -Wall
+
+source-repository head
+ type: git
+ location: http://github.com/acw/test-framework-program

0 comments on commit 0ffa89c

Please sign in to comment.
Something went wrong with that request. Please try again.