From: Iustin Pop <iustin@google.com>
Date: Sun, 7 Oct 2012 20:12:56 +0000 (+0200)
Subject: Remove custom OpResult type/monad
X-Git-Tag: v2.7.0beta1~783
X-Git-Url: https://code.grnet.gr/git/ganeti-local/commitdiff_plain/a8038349538bf2e08289d6709c096b476d1b63df

Remove custom OpResult type/monad

Since we now have the GeneralResult as a multi-purpose monad, we can
remove the custom OpResult monad, and just use 'GeneralResult
FailMode' as our type. This allows removal of a few bits of
specialised infrastructure, relying instead on the generic one.

The restriction on using OpResult as a general monad remains as
before.

Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Michael Hanselmann <hansmi@google.com>
---

diff --git a/htest/Test/Ganeti/HTools/Cluster.hs b/htest/Test/Ganeti/HTools/Cluster.hs
index 75f9980..6e79294 100644
--- a/htest/Test/Ganeti/HTools/Cluster.hs
+++ b/htest/Test/Ganeti/HTools/Cluster.hs
@@ -391,7 +391,7 @@ prop_AllocPolicy =
   forAll genOnlineNode $ \node ->
   forAll (choose (5, 20)) $ \count ->
   forAll (genInstanceSmallerThanNode node) $ \inst ->
-  forAll (arbitrary `suchThat` (isFailure .
+  forAll (arbitrary `suchThat` (isBad .
                                 Instance.instMatchesPolicy inst)) $ \ipol ->
   let rqn = Instance.requiredNodes $ Instance.diskTemplate inst
       node' = Node.setPolicy ipol node
diff --git a/htest/Test/Ganeti/HTools/Node.hs b/htest/Test/Ganeti/HTools/Node.hs
index 1230fad..7d32abf 100644
--- a/htest/Test/Ganeti/HTools/Node.hs
+++ b/htest/Test/Ganeti/HTools/Node.hs
@@ -45,6 +45,7 @@ import Test.Ganeti.TestCommon
 import Test.Ganeti.TestHTools
 import Test.Ganeti.HTools.Instance (genInstanceSmallerThanNode)
 
+import Ganeti.BasicTypes
 import qualified Ganeti.HTools.Container as Container
 import qualified Ganeti.HTools.Instance as Instance
 import qualified Ganeti.HTools.Node as Node
@@ -126,7 +127,7 @@ prop_addPriFM node inst =
   Instance.mem inst >= Node.fMem node && not (Node.failN1 node) &&
   not (Instance.isOffline inst) ==>
   case Node.addPri node inst'' of
-    Types.OpFail Types.FailMem -> True
+    Bad Types.FailMem -> True
     _ -> False
   where inst' = setInstanceSmallerThanNode node inst
         inst'' = inst' { Instance.mem = Instance.mem inst }
@@ -141,7 +142,7 @@ prop_addPriFD node inst =
       inst'' = inst' { Instance.dsk = Instance.dsk inst
                      , Instance.diskTemplate = dt }
   in case Node.addPri node inst'' of
-       Types.OpFail Types.FailDisk -> True
+       Bad Types.FailDisk -> True
        _ -> False
 
 -- | Check that adding a primary instance with too many VCPUs fails
@@ -154,7 +155,7 @@ prop_addPriFC =
   let inst' = setInstanceSmallerThanNode node inst
       inst'' = inst' { Instance.vcpus = Node.availCpu node + extra }
   in case Node.addPri node inst'' of
-       Types.OpFail Types.FailCPU -> passTest
+       Bad Types.FailCPU -> passTest
        v -> failTest $ "Expected OpFail FailCPU, but got " ++ show v
 
 -- | Check that an instance add with too high memory or disk will be
@@ -165,7 +166,7 @@ prop_addSec node inst pdx =
     not (Instance.isOffline inst)) ||
    Instance.dsk inst >= Node.fDsk node) &&
   not (Node.failN1 node) ==>
-      isFailure (Node.addSec node inst pdx)
+      isBad (Node.addSec node inst pdx)
 
 -- | Check that an offline instance with reasonable disk size but
 -- extra mem/cpu can always be added.
@@ -177,7 +178,7 @@ prop_addOfflinePri (NonNegative extra_mem) (NonNegative extra_cpu) =
                    , Instance.mem = Node.availMem node + extra_mem
                    , Instance.vcpus = Node.availCpu node + extra_cpu }
   in case Node.addPri node inst' of
-       Types.OpGood _ -> passTest
+       Ok _ -> passTest
        v -> failTest $ "Expected OpGood, but got: " ++ show v
 
 -- | Check that an offline instance with reasonable disk size but
@@ -192,7 +193,7 @@ prop_addOfflineSec (NonNegative extra_mem) (NonNegative extra_cpu) pdx =
                    , Instance.vcpus = Node.availCpu node + extra_cpu
                    , Instance.diskTemplate = Types.DTDrbd8 }
   in case Node.addSec node inst' pdx of
-       Types.OpGood _ -> passTest
+       Ok _ -> passTest
        v -> failTest $ "Expected OpGood/OpGood, but got: " ++ show v
 
 -- | Checks for memory reservation changes.
@@ -215,8 +216,8 @@ prop_rMem inst =
       node_del_ab = liftM (`Node.removeSec` inst_ab) node_add_ab
       node_del_nb = liftM (`Node.removeSec` inst_nb) node_add_nb
   in case (node_add_ab, node_add_nb, node_del_ab, node_del_nb) of
-       (Types.OpGood a_ab, Types.OpGood a_nb,
-        Types.OpGood d_ab, Types.OpGood d_nb) ->
+       (Ok a_ab, Ok a_nb,
+        Ok d_ab, Ok d_nb) ->
          printTestCase "Consistency checks failed" $
            Node.rMem a_ab >  orig_rmem &&
            Node.rMem a_ab - orig_rmem == Instance.mem inst_ab &&
@@ -275,7 +276,7 @@ prop_addPri_idempotent =
   forAll genOnlineNode $ \node ->
   forAll (genInstanceSmallerThanNode node) $ \inst ->
   case Node.addPri node inst of
-    Types.OpGood node' -> Node.removePri node' inst ==? node
+    Ok node' -> Node.removePri node' inst ==? node
     _ -> failTest "Can't add instance"
 
 prop_addSec_idempotent :: Property
@@ -286,7 +287,7 @@ prop_addSec_idempotent =
       inst' = Instance.setPri inst pdx
       inst'' = inst' { Instance.diskTemplate = Types.DTDrbd8 }
   in case Node.addSec node inst'' pdx of
-       Types.OpGood node' -> Node.removeSec node' inst'' ==? node
+       Ok node' -> Node.removeSec node' inst'' ==? node
        _ -> failTest "Can't add instance"
 
 testSuite "HTools/Node"
diff --git a/htest/Test/Ganeti/HTools/Types.hs b/htest/Test/Ganeti/HTools/Types.hs
index 5e124d5..d72bec6 100644
--- a/htest/Test/Ganeti/HTools/Types.hs
+++ b/htest/Test/Ganeti/HTools/Types.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, FlexibleInstances, TypeSynonymInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 {-| Unittests for ganeti-htools.
@@ -32,7 +32,6 @@ module Test.Ganeti.HTools.Types
   , Types.DiskTemplate(..)
   , Types.FailMode(..)
   , Types.EvacMode(..)
-  , Types.OpResult(..)
   , Types.ISpec(..)
   , Types.IPolicy(..)
   , nullIPolicy
@@ -68,8 +67,8 @@ $(genArbitrary ''Types.EvacMode)
 instance Arbitrary a => Arbitrary (Types.OpResult a) where
   arbitrary = arbitrary >>= \c ->
               if c
-                then Types.OpGood <$> arbitrary
-                else Types.OpFail <$> arbitrary
+                then Ok  <$> arbitrary
+                else Bad <$> arbitrary
 
 instance Arbitrary Types.ISpec where
   arbitrary = do
@@ -138,13 +137,13 @@ prop_IPolicy_serialisation = testSerialisation
 prop_EvacMode_serialisation :: Types.EvacMode -> Property
 prop_EvacMode_serialisation = testSerialisation
 
-prop_opToResult :: Types.OpResult Int -> Bool
+prop_opToResult :: Types.OpResult Int -> Property
 prop_opToResult op =
   case op of
-    Types.OpFail _ -> isBad r
-    Types.OpGood v -> case r of
-                        Bad _ -> False
-                        Ok v' -> v == v'
+    Bad _ -> printTestCase ("expected bad but got " ++ show r) $ isBad r
+    Ok v  -> case r of
+               Bad msg -> failTest ("expected Ok but got Bad " ++ msg)
+               Ok v' -> v ==? v'
   where r = Types.opToResult op
 
 prop_eitherToResult :: Either String Int -> Bool
diff --git a/htest/Test/Ganeti/TestHTools.hs b/htest/Test/Ganeti/TestHTools.hs
index 500d684..b33f766 100644
--- a/htest/Test/Ganeti/TestHTools.hs
+++ b/htest/Test/Ganeti/TestHTools.hs
@@ -84,11 +84,6 @@ defGroupList = Container.fromList [(Group.idx defGroup, defGroup)]
 defGroupAssoc :: Map.Map String Types.Gdx
 defGroupAssoc = Map.singleton (Group.uuid defGroup) (Group.idx defGroup)
 
--- | Simple checker for whether OpResult is fail or pass.
-isFailure :: Types.OpResult a -> Bool
-isFailure (Types.OpFail _) = True
-isFailure _ = False
-
 -- | Create an instance given its spec.
 createInstance :: Int -> Int -> Int -> Instance.Instance
 createInstance mem dsk vcpus =
diff --git a/htools/Ganeti/HTools/Cluster.hs b/htools/Ganeti/HTools/Cluster.hs
index 3542669..82d4757 100644
--- a/htools/Ganeti/HTools/Cluster.hs
+++ b/htools/Ganeti/HTools/Cluster.hs
@@ -517,8 +517,8 @@ checkSingleStep ini_tbl target cur_tbl move =
   let Table ini_nl ini_il _ ini_plc = ini_tbl
       tmp_resu = applyMove ini_nl target move
   in case tmp_resu of
-       OpFail _ -> cur_tbl
-       OpGood (upd_nl, new_inst, pri_idx, sec_idx) ->
+       Bad _ -> cur_tbl
+       Ok (upd_nl, new_inst, pri_idx, sec_idx) ->
          let tgt_idx = Instance.idx target
              upd_cvar = compCV upd_nl
              upd_il = Container.add tgt_idx new_inst ini_il
@@ -665,9 +665,9 @@ bestAllocElement a@(Just (_, _, _, ascore)) b@(Just (_, _, _, bscore)) =
 -- | Update current Allocation solution and failure stats with new
 -- elements.
 concatAllocs :: AllocSolution -> OpResult Node.AllocElement -> AllocSolution
-concatAllocs as (OpFail reason) = as { asFailures = reason : asFailures as }
+concatAllocs as (Bad reason) = as { asFailures = reason : asFailures as }
 
-concatAllocs as (OpGood ns) =
+concatAllocs as (Ok ns) =
   let -- Choose the old or new solution, based on the cluster score
     cntok = asAllocs as
     osols = asSolution as
@@ -1039,10 +1039,10 @@ evacOneNodeInner :: Node.List         -- ^ Cluster node list
                  -> EvacInnerState    -- ^ New best solution
 evacOneNodeInner nl inst gdx op_fn accu ndx =
   case applyMove nl inst (op_fn ndx) of
-    OpFail fm -> let fail_msg = "Node " ++ Container.nameOf nl ndx ++
-                                " failed: " ++ show fm
-                 in either (const $ Left fail_msg) (const accu) accu
-    OpGood (nl', inst', _, _) ->
+    Bad fm -> let fail_msg = "Node " ++ Container.nameOf nl ndx ++
+                             " failed: " ++ show fm
+              in either (const $ Left fail_msg) (const accu) accu
+    Ok (nl', inst', _, _) ->
       let nodes = Container.elems nl'
           -- The fromJust below is ugly (it can fail nastily), but
           -- at this point we should have any internal mismatches,
diff --git a/htools/Ganeti/HTools/Instance.hs b/htools/Ganeti/HTools/Instance.hs
index 9e3b2ef..ad96d7f 100644
--- a/htools/Ganeti/HTools/Instance.hs
+++ b/htools/Ganeti/HTools/Instance.hs
@@ -257,22 +257,22 @@ specOf Instance { mem = m, dsk = d, vcpus = c } =
   T.RSpec { T.rspecCpu = c, T.rspecMem = m, T.rspecDsk = d }
 
 -- | Checks if an instance is smaller than a given spec. Returns
--- OpGood for a correct spec, otherwise OpFail one of the possible
+-- OpGood for a correct spec, otherwise Bad one of the possible
 -- failure modes.
 instBelowISpec :: Instance -> T.ISpec -> T.OpResult ()
 instBelowISpec inst ispec
-  | mem inst > T.iSpecMemorySize ispec = T.OpFail T.FailMem
-  | dsk inst > T.iSpecDiskSize ispec   = T.OpFail T.FailDisk
-  | vcpus inst > T.iSpecCpuCount ispec = T.OpFail T.FailCPU
-  | otherwise = T.OpGood ()
+  | mem inst > T.iSpecMemorySize ispec = Bad T.FailMem
+  | dsk inst > T.iSpecDiskSize ispec   = Bad T.FailDisk
+  | vcpus inst > T.iSpecCpuCount ispec = Bad T.FailCPU
+  | otherwise = Ok ()
 
 -- | Checks if an instance is bigger than a given spec.
 instAboveISpec :: Instance -> T.ISpec -> T.OpResult ()
 instAboveISpec inst ispec
-  | mem inst < T.iSpecMemorySize ispec = T.OpFail T.FailMem
-  | dsk inst < T.iSpecDiskSize ispec   = T.OpFail T.FailDisk
-  | vcpus inst < T.iSpecCpuCount ispec = T.OpFail T.FailCPU
-  | otherwise = T.OpGood ()
+  | mem inst < T.iSpecMemorySize ispec = Bad T.FailMem
+  | dsk inst < T.iSpecDiskSize ispec   = Bad T.FailDisk
+  | vcpus inst < T.iSpecCpuCount ispec = Bad T.FailCPU
+  | otherwise = Ok ()
 
 -- | Checks if an instance matches a policy.
 instMatchesPolicy :: Instance -> T.IPolicy -> T.OpResult ()
@@ -280,8 +280,8 @@ instMatchesPolicy inst ipol = do
   instAboveISpec inst (T.iPolicyMinSpec ipol)
   instBelowISpec inst (T.iPolicyMaxSpec ipol)
   if diskTemplate inst `elem` T.iPolicyDiskTemplates ipol
-    then T.OpGood ()
-    else T.OpFail T.FailDisk
+    then Ok ()
+    else Bad T.FailDisk
 
 -- | Checks whether the instance uses a secondary node.
 --
diff --git a/htools/Ganeti/HTools/Node.hs b/htools/Ganeti/HTools/Node.hs
index 1a14af2..d6b98cb 100644
--- a/htools/Ganeti/HTools/Node.hs
+++ b/htools/Ganeti/HTools/Node.hs
@@ -82,6 +82,7 @@ import qualified Ganeti.HTools.Container as Container
 import qualified Ganeti.HTools.Instance as Instance
 import qualified Ganeti.HTools.PeerMap as P
 
+import Ganeti.BasicTypes
 import qualified Ganeti.HTools.Types as T
 
 -- * Type declarations
@@ -444,14 +445,14 @@ addPriEx force t inst =
       old_tags = pTags t
       strict = not force
   in case () of
-       _ | new_mem <= 0 -> T.OpFail T.FailMem
-         | uses_disk && new_dsk <= 0 -> T.OpFail T.FailDisk
-         | uses_disk && mDsk t > new_dp && strict -> T.OpFail T.FailDisk
+       _ | new_mem <= 0 -> Bad T.FailMem
+         | uses_disk && new_dsk <= 0 -> Bad T.FailDisk
+         | uses_disk && mDsk t > new_dp && strict -> Bad T.FailDisk
          | uses_disk && new_spindles > hiSpindles t
-             && strict -> T.OpFail T.FailDisk
-         | new_failn1 && not (failN1 t) && strict -> T.OpFail T.FailMem
-         | l_cpu >= 0 && l_cpu < new_pcpu && strict -> T.OpFail T.FailCPU
-         | rejectAddTags old_tags inst_tags -> T.OpFail T.FailTags
+             && strict -> Bad T.FailDisk
+         | new_failn1 && not (failN1 t) && strict -> Bad T.FailMem
+         | l_cpu >= 0 && l_cpu < new_pcpu && strict -> Bad T.FailCPU
+         | rejectAddTags old_tags inst_tags -> Bad T.FailTags
          | otherwise ->
            let new_plist = iname:pList t
                new_mp = fromIntegral new_mem / tMem t
@@ -462,7 +463,7 @@ addPriEx force t inst =
                      , pTags = addTags old_tags inst_tags
                      , instSpindles = new_spindles
                      }
-           in T.OpGood r
+           in Ok r
 
 -- | Adds a secondary instance (basic version).
 addSec :: Node -> Instance.Instance -> T.Ndx -> T.OpResult Node
@@ -490,12 +491,12 @@ addSecEx force t inst pdx =
                                           T.dskWeight (Instance.util inst) }
       strict = not force
   in case () of
-       _ | not (Instance.hasSecondary inst) -> T.OpFail T.FailDisk
-         | new_dsk <= 0 -> T.OpFail T.FailDisk
-         | mDsk t > new_dp && strict -> T.OpFail T.FailDisk
-         | new_spindles > hiSpindles t && strict -> T.OpFail T.FailDisk
-         | secondary_needed_mem >= old_mem && strict -> T.OpFail T.FailMem
-         | new_failn1 && not (failN1 t) && strict -> T.OpFail T.FailMem
+       _ | not (Instance.hasSecondary inst) -> Bad T.FailDisk
+         | new_dsk <= 0 -> Bad T.FailDisk
+         | mDsk t > new_dp && strict -> Bad T.FailDisk
+         | new_spindles > hiSpindles t && strict -> Bad T.FailDisk
+         | secondary_needed_mem >= old_mem && strict -> Bad T.FailMem
+         | new_failn1 && not (failN1 t) && strict -> Bad T.FailMem
          | otherwise ->
            let new_slist = iname:sList t
                r = t { sList = new_slist, fDsk = new_dsk
@@ -504,7 +505,7 @@ addSecEx force t inst pdx =
                      , pRem = new_prem, utilLoad = new_load
                      , instSpindles = new_spindles
                      }
-           in T.OpGood r
+           in Ok r
 
 -- * Stats functions
 
diff --git a/htools/Ganeti/HTools/Types.hs b/htools/Ganeti/HTools/Types.hs
index b625cef..7efda99 100644
--- a/htools/Ganeti/HTools/Types.hs
+++ b/htools/Ganeti/HTools/Types.hs
@@ -65,7 +65,7 @@ module Ganeti.HTools.Types
   , Element(..)
   , FailMode(..)
   , FailStats
-  , OpResult(..)
+  , OpResult
   , opToResult
   , EvacMode(..)
   , ISpec(..)
@@ -344,21 +344,20 @@ type FailStats = [(FailMode, Int)]
 -- The failure values for this monad track the specific allocation
 -- failures, so this is not a general error-monad (compare with the
 -- 'Result' data type). One downside is that this type cannot encode a
--- generic failure mode, hence 'fail' for this monad is not defined
--- and will cause an exception.
-data OpResult a = OpFail FailMode -- ^ Failed operation
-                | OpGood a        -- ^ Success operation
-                  deriving (Show, Read)
+-- generic failure mode, hence our way to build a FailMode from string
+-- will instead raise an exception.
+type OpResult = GenericResult FailMode
 
-instance Monad OpResult where
-  (OpGood x) >>= fn = fn x
-  (OpFail y) >>= _ = OpFail y
-  return = OpGood
+-- | 'FromString' instance for 'FailMode' designed to catch unintended
+-- use as a general monad.
+instance FromString FailMode where
+  mkFromString v = error $ "Programming error: OpResult used as generic monad"
+                           ++ v
 
 -- | Conversion from 'OpResult' to 'Result'.
 opToResult :: OpResult a -> Result a
-opToResult (OpFail f) = Bad $ show f
-opToResult (OpGood v) = Ok v
+opToResult (Bad f) = Bad $ show f
+opToResult (Ok v) = Ok v
 
 -- | A generic class for items that have updateable names and indices.
 class Element a where