diff --git a/htools/Ganeti/BasicTypes.hs b/htools/Ganeti/BasicTypes.hs
index ec3e138af7a8d4076671ef75c5f17265fd328a1f..55bab28588848679f353d45b50d5fe458657c65d 100644
--- a/htools/Ganeti/BasicTypes.hs
+++ b/htools/Ganeti/BasicTypes.hs
@@ -26,9 +26,19 @@ module Ganeti.BasicTypes
, eitherToResult
, annotateResult
, annotateIOError
+ , select
+ , LookupResult(..)
+ , MatchPriority(..)
+ , lookupName
+ , goodLookupResult
+ , goodMatchPriority
+ , prefixMatch
+ , compareNameComponent
) where
import Control.Monad
+import Data.Function
+import Data.List
-- | This is similar to the JSON library Result type - /very/ similar,
-- but we want to use it in multiple places, so we abstract it into a
@@ -78,3 +88,85 @@ annotateResult _ v = v
annotateIOError :: String -> IOError -> IO (Result a)
annotateIOError description exc =
return . Bad $ description ++ ": " ++ show exc
+
+-- * Misc functionality
+
+-- | Return the first result with a True condition, or the default otherwise.
+select :: a -- ^ default result
+ -> [(Bool, a)] -- ^ list of \"condition, result\"
+ -> a -- ^ first result which has a True condition, or default
+select def = maybe def snd . find fst
+
+-- * Lookup of partial names functionality
+
+-- | The priority of a match in a lookup result.
+data MatchPriority = ExactMatch
+ | MultipleMatch
+ | PartialMatch
+ | FailMatch
+ deriving (Show, Read, Enum, Eq, Ord)
+
+-- | The result of a name lookup in a list.
+data LookupResult = LookupResult
+ { lrMatchPriority :: MatchPriority -- ^ The result type
+ -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
+ , lrContent :: String
+ } deriving (Show, Read)
+
+-- | Lookup results have an absolute preference ordering.
+instance Eq LookupResult where
+ (==) = (==) `on` lrMatchPriority
+
+instance Ord LookupResult where
+ compare = compare `on` lrMatchPriority
+
+-- | Check for prefix matches in names.
+-- Implemented in Ganeti core utils.text.MatchNameComponent
+-- as the regexp r"^%s(\..*)?$" % re.escape(key)
+prefixMatch :: String -- ^ Lookup
+ -> String -- ^ Full name
+ -> Bool -- ^ Whether there is a prefix match
+prefixMatch = isPrefixOf . (++ ".")
+
+-- | Is the lookup priority a "good" one?
+goodMatchPriority :: MatchPriority -> Bool
+goodMatchPriority ExactMatch = True
+goodMatchPriority PartialMatch = True
+goodMatchPriority _ = False
+
+-- | Is the lookup result an actual match?
+goodLookupResult :: LookupResult -> Bool
+goodLookupResult = goodMatchPriority . lrMatchPriority
+
+-- | Compares a canonical name and a lookup string.
+compareNameComponent :: String -- ^ Canonical (target) name
+ -> String -- ^ Partial (lookup) name
+ -> LookupResult -- ^ Result of the lookup
+compareNameComponent cnl lkp =
+ select (LookupResult FailMatch lkp)
+ [ (cnl == lkp , LookupResult ExactMatch cnl)
+ , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)
+ ]
+
+-- | Lookup a string and choose the best result.
+chooseLookupResult :: String -- ^ Lookup key
+ -> String -- ^ String to compare to the lookup key
+ -> LookupResult -- ^ Previous result
+ -> LookupResult -- ^ New result
+chooseLookupResult lkp cstr old =
+ -- default: use class order to pick the minimum result
+ select (min new old)
+ -- special cases:
+ -- short circuit if the new result is an exact match
+ [ (lrMatchPriority new == ExactMatch, new)
+ -- if both are partial matches generate a multiple match
+ , (partial2, LookupResult MultipleMatch lkp)
+ ] where new = compareNameComponent cstr lkp
+ partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]
+
+-- | Find the canonical name for a lookup string in a list of names.
+lookupName :: [String] -- ^ List of keys
+ -> String -- ^ Lookup string
+ -> LookupResult -- ^ Result of the lookup
+lookupName l s = foldr (chooseLookupResult s)
+ (LookupResult FailMatch s) l
diff --git a/htools/Ganeti/HTools/CLI.hs b/htools/Ganeti/HTools/CLI.hs
index 4636fd7a0446f24fafb3f372bc34dd8677a6e208..29f17288fcf6f3718ec000baa9c9a38b7cfe9876 100644
--- a/htools/Ganeti/HTools/CLI.hs
+++ b/htools/Ganeti/HTools/CLI.hs
@@ -100,7 +100,7 @@ import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.Constants as C
import Ganeti.HTools.Types
import Ganeti.HTools.Utils
-import Ganeti.HTools.Loader
+import Ganeti.BasicTypes
-- * Constants
diff --git a/htools/Ganeti/HTools/Loader.hs b/htools/Ganeti/HTools/Loader.hs
index 5a5da6542a38a33236e3c39e1e82ad28044c148b..851c84bb9f83deffc22787eea9023f9477287d48 100644
--- a/htools/Ganeti/HTools/Loader.hs
+++ b/htools/Ganeti/HTools/Loader.hs
@@ -30,8 +30,6 @@ module Ganeti.HTools.Loader
( mergeData
, checkData
, assignIndices
- , lookupName
- , goodLookupResult
, lookupNode
, lookupInstance
, lookupGroup
@@ -40,14 +38,9 @@ module Ganeti.HTools.Loader
, Request(..)
, ClusterData(..)
, emptyCluster
- , compareNameComponent
- , prefixMatch
- , LookupResult(..)
- , MatchPriority(..)
) where
import Data.List
-import Data.Function
import qualified Data.Map as M
import Text.Printf (printf)
@@ -57,6 +50,7 @@ import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Group as Group
import qualified Ganeti.HTools.Cluster as Cluster
+import Ganeti.BasicTypes
import Ganeti.HTools.Types
import Ganeti.HTools.Utils
@@ -94,27 +88,6 @@ data ClusterData = ClusterData
, cdIPolicy :: IPolicy -- ^ The cluster instance policy
} deriving (Show, Read, Eq)
--- | The priority of a match in a lookup result.
-data MatchPriority = ExactMatch
- | MultipleMatch
- | PartialMatch
- | FailMatch
- deriving (Show, Read, Enum, Eq, Ord)
-
--- | The result of a name lookup in a list.
-data LookupResult = LookupResult
- { lrMatchPriority :: MatchPriority -- ^ The result type
- -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
- , lrContent :: String
- } deriving (Show, Read)
-
--- | Lookup results have an absolute preference ordering.
-instance Eq LookupResult where
- (==) = (==) `on` lrMatchPriority
-
-instance Ord LookupResult where
- compare = compare `on` lrMatchPriority
-
-- | An empty cluster.
emptyCluster :: ClusterData
emptyCluster = ClusterData Container.empty Container.empty Container.empty []
@@ -143,57 +116,6 @@ lookupGroup ktg nname gname =
Nothing -> fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname
Just idx -> return idx
--- | Check for prefix matches in names.
--- Implemented in Ganeti core utils.text.MatchNameComponent
--- as the regexp r"^%s(\..*)?$" % re.escape(key)
-prefixMatch :: String -- ^ Lookup
- -> String -- ^ Full name
- -> Bool -- ^ Whether there is a prefix match
-prefixMatch = isPrefixOf . (++ ".")
-
--- | Is the lookup priority a "good" one?
-goodMatchPriority :: MatchPriority -> Bool
-goodMatchPriority ExactMatch = True
-goodMatchPriority PartialMatch = True
-goodMatchPriority _ = False
-
--- | Is the lookup result an actual match?
-goodLookupResult :: LookupResult -> Bool
-goodLookupResult = goodMatchPriority . lrMatchPriority
-
--- | Compares a canonical name and a lookup string.
-compareNameComponent :: String -- ^ Canonical (target) name
- -> String -- ^ Partial (lookup) name
- -> LookupResult -- ^ Result of the lookup
-compareNameComponent cnl lkp =
- select (LookupResult FailMatch lkp)
- [ (cnl == lkp , LookupResult ExactMatch cnl)
- , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)
- ]
-
--- | Lookup a string and choose the best result.
-chooseLookupResult :: String -- ^ Lookup key
- -> String -- ^ String to compare to the lookup key
- -> LookupResult -- ^ Previous result
- -> LookupResult -- ^ New result
-chooseLookupResult lkp cstr old =
- -- default: use class order to pick the minimum result
- select (min new old)
- -- special cases:
- -- short circuit if the new result is an exact match
- [ (lrMatchPriority new == ExactMatch, new)
- -- if both are partial matches generate a multiple match
- , (partial2, LookupResult MultipleMatch lkp)
- ] where new = compareNameComponent cstr lkp
- partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]
-
--- | Find the canonical name for a lookup string in a list of names.
-lookupName :: [String] -- ^ List of keys
- -> String -- ^ Lookup string
- -> LookupResult -- ^ Result of the lookup
-lookupName l s = foldr (chooseLookupResult s)
- (LookupResult FailMatch s) l
-
-- | Given a list of elements (and their names), assign indices to them.
assignIndices :: (Element a) =>
[(String, a)]
diff --git a/htools/Ganeti/HTools/QC.hs b/htools/Ganeti/HTools/QC.hs
index d056a9c95ceb5d0df0fb1d36cd8ab9cb05629053..c00e22d1523391b1b1907102f0f16b136958154b 100644
--- a/htools/Ganeti/HTools/QC.hs
+++ b/htools/Ganeti/HTools/QC.hs
@@ -56,6 +56,7 @@ import qualified Text.JSON as J
import qualified Data.Map
import qualified Data.IntMap as IntMap
+import qualified Ganeti.BasicTypes as BasicTypes
import qualified Ganeti.OpCodes as OpCodes
import qualified Ganeti.Jobs as Jobs
import qualified Ganeti.Luxi as Luxi
@@ -1517,14 +1518,14 @@ prop_Loader_mergeData ns =
-- | Check that compareNameComponent on equal strings works.
prop_Loader_compareNameComponent_equal :: String -> Bool
prop_Loader_compareNameComponent_equal s =
- Loader.compareNameComponent s s ==
- Loader.LookupResult Loader.ExactMatch s
+ BasicTypes.compareNameComponent s s ==
+ BasicTypes.LookupResult BasicTypes.ExactMatch s
-- | Check that compareNameComponent on prefix strings works.
prop_Loader_compareNameComponent_prefix :: NonEmptyList Char -> String -> Bool
prop_Loader_compareNameComponent_prefix (NonEmpty s1) s2 =
- Loader.compareNameComponent (s1 ++ "." ++ s2) s1 ==
- Loader.LookupResult Loader.PartialMatch s1
+ BasicTypes.compareNameComponent (s1 ++ "." ++ s2) s1 ==
+ BasicTypes.LookupResult BasicTypes.PartialMatch s1
testSuite "Loader"
[ 'prop_Loader_lookupNode
diff --git a/htools/Ganeti/HTools/Utils.hs b/htools/Ganeti/HTools/Utils.hs
index aaf4fb093e17183f4dae10973b0c277ff1f64c61..2b21518c4177a51552ce357cc39e92507f5d2a4e 100644
--- a/htools/Ganeti/HTools/Utils.hs
+++ b/htools/Ganeti/HTools/Utils.hs
@@ -132,13 +132,6 @@ if' :: Bool -- ^ condition
if' True x _ = x
if' _ _ y = y
--- | Return the first result with a True condition, or the default otherwise.
-select :: a -- ^ default result
- -> [(Bool, a)] -- ^ list of \"condition, result\"
- -> a -- ^ first result which has a True condition, or default
-select def = maybe def snd . find fst
-
-
-- * Parsing utility functions
-- | Parse results from readsPrec.