From efe989652896b0702b461b90405435c12c26a2cb Mon Sep 17 00:00:00 2001
From: Guido Trotter <ultrotter@google.com>
Date: Thu, 7 Jul 2011 14:37:25 +0100
Subject: [PATCH] htools: infrastructure for looking up names

Signed-off-by: Guido Trotter <ultrotter@google.com>
Reviewed-by: Iustin Pop <iustin@google.com>
---
 htools/Ganeti/HTools/Loader.hs | 78 ++++++++++++++++++++++++++++++++++
 htools/Ganeti/HTools/QC.hs     | 14 ++++++
 2 files changed, 92 insertions(+)

diff --git a/htools/Ganeti/HTools/Loader.hs b/htools/Ganeti/HTools/Loader.hs
index 7331a59a3..3e94eb593 100644
--- a/htools/Ganeti/HTools/Loader.hs
+++ b/htools/Ganeti/HTools/Loader.hs
@@ -40,9 +40,14 @@ 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)
 
@@ -52,6 +57,7 @@ import qualified Ganeti.HTools.Node as Node
 import qualified Ganeti.HTools.Group as Group
 
 import Ganeti.HTools.Types
+import Ganeti.HTools.Utils
 
 -- * Constants
 
@@ -94,6 +100,27 @@ data ClusterData = ClusterData
     , cdTags      :: [String]      -- ^ The cluster tags
     } deriving (Show, Read)
 
+-- | 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 []
@@ -121,6 +148,57 @@ 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 lkp = isPrefixOf (lkp ++ ".")
+
+-- | 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 871ad849d..597203eda 100644
--- a/htools/Ganeti/HTools/QC.hs
+++ b/htools/Ganeti/HTools/QC.hs
@@ -992,11 +992,25 @@ prop_Loader_mergeData ns =
       in (sum . map (length . Node.pList)) nodes == 0 &&
          null instances
 
+-- | 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
+
+-- | 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
+
 testLoader =
   [ run prop_Loader_lookupNode
   , run prop_Loader_lookupInstance
   , run prop_Loader_assignIndices
   , run prop_Loader_mergeData
+  , run prop_Loader_compareNameComponent_equal
+  , run prop_Loader_compareNameComponent_prefix
   ]
 
 -- ** Types tests
-- 
GitLab