Add more basic validation types

This mirrors the ht.py types PositiveInt, NonNegative, etc., except
that they work at a more generic level (any numeric type, respectively
any non-empty list).

Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Adeodato Simo <dato@google.com>

htest/Test/Ganeti/Types.hs

@@ -31,23 +31,37 @@ module Test.Ganeti.Types
   , AllocPolicy(..)
   , DiskTemplate(..)
   , InstanceStatus(..)
+  , NonEmpty(..)
   ) where
 
-import Test.QuickCheck
+import Test.QuickCheck as QuickCheck hiding (Result)
+import Test.HUnit
 
 import Test.Ganeti.TestHelper
 import Test.Ganeti.TestCommon
 
-import Ganeti.Types
+import Ganeti.BasicTypes
+import Ganeti.Types as Types
 
 -- * Arbitrary instance
 
+instance (Arbitrary a, Ord a, Num a, Show a) =>
+  Arbitrary (Types.Positive a) where
+  arbitrary = do
+    (QuickCheck.Positive i) <- arbitrary
+    Types.mkPositive i
+
 $(genArbitrary ''AllocPolicy)
 
 $(genArbitrary ''DiskTemplate)
 
 $(genArbitrary ''InstanceStatus)
 
+instance (Arbitrary a) => Arbitrary (Types.NonEmpty a) where
+  arbitrary = do
+    QuickCheck.NonEmpty lst <- arbitrary
+    Types.mkNonEmpty lst
+
 prop_AllocPolicy_serialisation :: AllocPolicy -> Property
 prop_AllocPolicy_serialisation = testSerialisation
 
@@ -57,8 +71,57 @@ prop_DiskTemplate_serialisation = testSerialisation
 prop_InstanceStatus_serialisation :: InstanceStatus -> Property
 prop_InstanceStatus_serialisation = testSerialisation
 
+-- | Tests building non-negative numbers.
+prop_NonNeg_pass :: QuickCheck.NonNegative Int -> Property
+prop_NonNeg_pass (QuickCheck.NonNegative i) =
+  case mkNonNegative i of
+    Bad msg -> failTest $ "Fail to build non-negative: " ++ msg
+    Ok nn -> fromNonNegative nn ==? i
+
+-- | Tests building non-negative numbers.
+prop_NonNeg_fail :: QuickCheck.Positive Int -> Property
+prop_NonNeg_fail (QuickCheck.Positive i) =
+  case mkNonNegative (negate i)::Result (Types.NonNegative Int) of
+    Bad _ -> passTest
+    Ok nn -> failTest $ "Built non-negative number '" ++ show nn ++
+             "' from negative value " ++ show i
+
+-- | Tests building positive numbers.
+prop_Positive_pass :: QuickCheck.Positive Int -> Property
+prop_Positive_pass (QuickCheck.Positive i) =
+  case mkPositive i of
+    Bad msg -> failTest $ "Fail to build positive: " ++ msg
+    Ok nn -> fromPositive nn ==? i
+
+-- | Tests building positive numbers.
+prop_Positive_fail :: QuickCheck.NonNegative Int -> Property
+prop_Positive_fail (QuickCheck.NonNegative i) =
+  case mkPositive (negate i)::Result (Types.Positive Int) of
+    Bad _ -> passTest
+    Ok nn -> failTest $ "Built positive number '" ++ show nn ++
+             "' from negative or zero value " ++ show i
+
+-- | Tests building non-empty lists.
+prop_NonEmpty_pass :: QuickCheck.NonEmptyList [Char] -> Property
+prop_NonEmpty_pass (QuickCheck.NonEmpty xs) =
+  case mkNonEmpty xs of
+    Bad msg -> failTest $ "Fail to build non-empty list: " ++ msg
+    Ok nn -> fromNonEmpty nn ==? xs
+
+-- | Tests building positive numbers.
+case_NonEmpty_fail :: Assertion
+case_NonEmpty_fail = do
+  assertEqual "building non-empty list from an empty list"
+    (Bad "Received empty value for non-empty list") (mkNonEmpty ([]::[Int]))
+
 testSuite "Types"
   [ 'prop_AllocPolicy_serialisation
   , 'prop_DiskTemplate_serialisation
   , 'prop_InstanceStatus_serialisation
+  , 'prop_NonNeg_pass
+  , 'prop_NonNeg_fail
+  , 'prop_Positive_pass
+  , 'prop_Positive_fail
+  , 'prop_NonEmpty_pass
+  , 'case_NonEmpty_fail
   ]

htools/Ganeti/Types.hs

@@ -40,11 +40,67 @@ module Ganeti.Types
   , DiskTemplate(..)
   , diskTemplateToRaw
   , diskTemplateFromRaw
+  , NonNegative
+  , fromNonNegative
+  , mkNonNegative
+  , Positive
+  , fromPositive
+  , mkPositive
+  , NonEmpty
+  , fromNonEmpty
+  , mkNonEmpty
   ) where
 
+import qualified Text.JSON as JSON
+
 import qualified Ganeti.Constants as C
 import qualified Ganeti.THH as THH
 
+-- * Generic types
+
+-- | Type that holds a non-negative value.
+newtype NonNegative a = NonNegative { fromNonNegative :: a }
+  deriving (Show, Read, Eq)
+
+-- | Smart constructor for 'NonNegative'.
+mkNonNegative :: (Monad m, Num a, Ord a, Show a) => a -> m (NonNegative a)
+mkNonNegative i | i >= 0 = return (NonNegative i)
+                | otherwise = fail $ "Invalid value for non-negative type '" ++
+                              show i ++ "'"
+
+instance (JSON.JSON a, Num a, Ord a, Show a) => JSON.JSON (NonNegative a) where
+  showJSON = JSON.showJSON . fromNonNegative
+  readJSON v = JSON.readJSON v >>= mkNonNegative
+
+-- | Type that holds a positive value.
+newtype Positive a = Positive { fromPositive :: a }
+  deriving (Show, Read, Eq)
+
+-- | Smart constructor for 'Positive'.
+mkPositive :: (Monad m, Num a, Ord a, Show a) => a -> m (Positive a)
+mkPositive i | i > 0 = return (Positive i)
+             | otherwise = fail $ "Invalid value for positive type '" ++
+                           show i ++ "'"
+
+instance (JSON.JSON a, Num a, Ord a, Show a) => JSON.JSON (Positive a) where
+  showJSON = JSON.showJSON . fromPositive
+  readJSON v = JSON.readJSON v >>= mkPositive
+
+-- | Type that holds a non-null list.
+newtype NonEmpty a = NonEmpty { fromNonEmpty :: [a] }
+  deriving (Show, Read, Eq)
+
+-- | Smart constructor for 'NonEmpty'.
+mkNonEmpty :: (Monad m) => [a] -> m (NonEmpty a)
+mkNonEmpty [] = fail "Received empty value for non-empty list"
+mkNonEmpty xs = return (NonEmpty xs)
+
+instance (JSON.JSON a) => JSON.JSON (NonEmpty a) where
+  showJSON = JSON.showJSON . fromNonEmpty
+  readJSON v = JSON.readJSON v >>= mkNonEmpty
+
+-- * Ganeti types
+
 -- | Instance disk template type.
 $(THH.declareSADT "DiskTemplate"
        [ ("DTDiskless",   'C.dtDiskless)