Add entire ConfigData serialisation tests

[ganeti-local] / htools / Ganeti / BasicTypes.hs

diff --git a/htools/Ganeti/BasicTypes.hs b/htools/Ganeti/BasicTypes.hs
index ec3e138..61a7e56 100644 (file)
--- a/htools/Ganeti/BasicTypes.hs
+++ b/htools/Ganeti/BasicTypes.hs
@@ -26,9 +26,20 @@ module Ganeti.BasicTypes
   , eitherToResult
   , annotateResult
   , annotateIOError
+  , select
+  , LookupResult(..)
+  , MatchPriority(..)
+  , lookupName
+  , goodLookupResult
+  , goodMatchPriority
+  , prefixMatch
+  , compareNameComponent
   ) where
 
+import Control.Applicative
 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
@@ -46,6 +57,10 @@ instance Monad Result where
   return = Ok
   fail = Bad
 
+instance Functor Result where
+  fmap _ (Bad msg) = Bad msg
+  fmap fn (Ok val) = Ok (fn val)
+
 instance MonadPlus Result where
   mzero = Bad "zero Result when used as MonadPlus"
   -- for mplus, when we 'add' two Bad values, we concatenate their
@@ -54,6 +69,12 @@ instance MonadPlus Result where
   (Bad _) `mplus` x = x
   x@(Ok _) `mplus` _ = x
 
+instance Applicative Result where
+  pure = Ok
+  (Bad f) <*> _       = Bad f
+  _       <*> (Bad x) = Bad x
+  (Ok f)  <*> (Ok x)  = Ok $ f x
+
 -- | Simple checker for whether a 'Result' is OK.
 isOk :: Result a -> Bool
 isOk (Ok _) = True
@@ -78,3 +99,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