Improve the `CanTieredAlloc' test

[ganeti-local] / htest / Test / Ganeti / TestCommon.hs

diff --git a/htest/Test/Ganeti/TestCommon.hs b/htest/Test/Ganeti/TestCommon.hs
index 5ac3f63..27796fc 100644 (file)
--- a/htest/Test/Ganeti/TestCommon.hs
+++ b/htest/Test/Ganeti/TestCommon.hs
@@ -26,8 +26,19 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 module Test.Ganeti.TestCommon where
 
 import Control.Applicative
+import Control.Exception (catchJust)
+import Control.Monad
 import Data.List
+import qualified Test.HUnit as HUnit
 import Test.QuickCheck
+import Test.QuickCheck.Monadic
+import qualified Text.JSON as J
+import System.Environment (getEnv)
+import System.Exit (ExitCode(..))
+import System.IO.Error (isDoesNotExistError)
+import System.Process (readProcessWithExitCode)
+
+import qualified Ganeti.BasicTypes as BasicTypes
 
 -- * Constants
 
@@ -73,6 +84,30 @@ infix 3 ==?
 failTest :: String -> Property
 failTest msg = printTestCase msg False
 
+-- | A 'True' property.
+passTest :: Property
+passTest = property True
+
+-- | Return the python binary to use. If the PYTHON environment
+-- variable is defined, use its value, otherwise use just \"python\".
+pythonCmd :: IO String
+pythonCmd = catchJust (guard . isDoesNotExistError)
+            (getEnv "PYTHON") (const (return "python"))
+
+-- | Run Python with an expression, returning the exit code, standard
+-- output and error.
+runPython :: String -> String -> IO (ExitCode, String, String)
+runPython expr stdin = do
+  py_binary <- pythonCmd
+  readProcessWithExitCode py_binary ["-c", expr] stdin
+
+-- | Check python exit code, and fail via HUnit assertions if
+-- non-zero. Otherwise, return the standard output.
+checkPythonResult :: (ExitCode, String, String) -> IO String
+checkPythonResult (py_code, py_stdout, py_stderr) = do
+  HUnit.assertEqual ("python exited with error: " ++ py_stderr)
+       ExitSuccess py_code
+  return py_stdout
 
 -- * Arbitrary instances
 
@@ -108,3 +143,67 @@ getMaybe subgen = do
   if bool
     then Just <$> subgen
     else return Nothing
+
+-- | Defines a tag type.
+newtype TagChar = TagChar { tagGetChar :: Char }
+
+-- | All valid tag chars. This doesn't need to match _exactly_
+-- Ganeti's own tag regex, just enough for it to be close.
+tagChar :: String
+tagChar = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ".+*/:@-"
+
+instance Arbitrary TagChar where
+  arbitrary = do
+    c <- elements tagChar
+    return (TagChar c)
+
+-- | Generates a tag
+genTag :: Gen [TagChar]
+genTag = do
+  -- the correct value would be C.maxTagLen, but that's way too
+  -- verbose in unittests, and at the moment I don't see any possible
+  -- bugs with longer tags and the way we use tags in htools
+  n <- choose (1, 10)
+  vector n
+
+-- | Generates a list of tags (correctly upper bounded).
+genTags :: Gen [String]
+genTags = do
+  -- the correct value would be C.maxTagsPerObj, but per the comment
+  -- in genTag, we don't use tags enough in htools to warrant testing
+  -- such big values
+  n <- choose (0, 10::Int)
+  tags <- mapM (const genTag) [1..n]
+  return $ map (map tagGetChar) tags
+
+-- | Generates a fields list. This uses the same character set as a
+-- DNS name (just for simplicity).
+getFields :: Gen [String]
+getFields = do
+  n <- choose (1, 32)
+  vectorOf n getName
+
+-- | Generates a list of a given size with non-duplicate elements.
+genUniquesList :: (Eq a, Arbitrary a) => Int -> Gen [a]
+genUniquesList cnt =
+  foldM (\lst _ -> do
+           newelem <- arbitrary `suchThat` (`notElem` lst)
+           return (newelem:lst)) [] [1..cnt]
+
+newtype SmallRatio = SmallRatio Double deriving Show
+instance Arbitrary SmallRatio where
+  arbitrary = do
+    v <- choose (0, 1)
+    return $ SmallRatio v
+
+-- | Checks for serialisation idempotence.
+testSerialisation :: (Eq a, Show a, J.JSON a) => a -> Property
+testSerialisation a =
+  case J.readJSON (J.showJSON a) of
+    J.Error msg -> failTest $ "Failed to deserialise: " ++ msg
+    J.Ok a' -> a ==? a'
+
+-- | Result to PropertyM IO.
+resultProp :: BasicTypes.Result a -> PropertyM IO a
+resultProp (BasicTypes.Bad msg) = stop $ failTest msg
+resultProp (BasicTypes.Ok  val) = return val