+{-# LANGUAGE FlexibleInstances #-}
+
{-
-Copyright (C) 2009, 2010, 2011 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-}
module Ganeti.BasicTypes
- ( Result(..)
+ ( GenericResult(..)
+ , Result
+ , ResultT(..)
+ , resultT
+ , FromString(..)
, isOk
, isBad
, eitherToResult
, annotateResult
+ , annotateIOError
+ , select
+ , LookupResult(..)
+ , MatchPriority(..)
+ , lookupName
+ , goodLookupResult
+ , goodMatchPriority
+ , prefixMatch
+ , compareNameComponent
) where
+import Control.Applicative
import Control.Monad
+import Control.Monad.Trans
+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
--- mini-library here.
---
--- The failure value for this monad is simply a string.
-data Result a
- = Bad String
- | Ok a
+-- | Generic monad for our error handling mechanisms.
+data GenericResult a b
+ = Bad a
+ | Ok b
deriving (Show, Read, Eq)
-instance Monad Result where
+-- | Type alias for a string Result.
+type Result = GenericResult String
+
+-- | Type class for things that can be built from strings.
+class FromString a where
+ mkFromString :: String -> a
+
+-- | Trivial 'String' instance; requires FlexibleInstances extension
+-- though.
+instance FromString [Char] where
+ mkFromString = id
+
+-- | 'Monad' instance for 'GenericResult'.
+instance (FromString a) => Monad (GenericResult a) where
(>>=) (Bad x) _ = Bad x
(>>=) (Ok x) fn = fn x
return = Ok
- fail = Bad
+ fail = Bad . mkFromString
-instance MonadPlus Result where
+instance Functor (GenericResult a) where
+ fmap _ (Bad msg) = Bad msg
+ fmap fn (Ok val) = Ok (fn val)
+
+instance MonadPlus (GenericResult String) where
mzero = Bad "zero Result when used as MonadPlus"
-- for mplus, when we 'add' two Bad values, we concatenate their
-- error descriptions
(Bad _) `mplus` x = x
x@(Ok _) `mplus` _ = x
--- | Simple checker for whether a 'Result' is OK.
-isOk :: Result a -> Bool
+instance Applicative (GenericResult a) where
+ pure = Ok
+ (Bad f) <*> _ = Bad f
+ _ <*> (Bad x) = Bad x
+ (Ok f) <*> (Ok x) = Ok $ f x
+
+-- | This is a monad transformation for Result. It's implementation is
+-- based on the implementations of MaybeT and ErrorT.
+newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)}
+
+instance (Monad m, FromString a) => Monad (ResultT a m) where
+ fail err = ResultT (return . Bad $ mkFromString err)
+ return = lift . return
+ x >>= f = ResultT $ do
+ a <- runResultT x
+ case a of
+ Ok val -> runResultT $ f val
+ Bad err -> return $ Bad err
+
+instance MonadTrans (ResultT a) where
+ lift x = ResultT (liftM Ok x)
+
+instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where
+ liftIO = lift . liftIO
+
+-- | Lift a `Result` value to a `ResultT`.
+resultT :: Monad m => GenericResult a b -> ResultT a m b
+resultT = ResultT . return
+
+-- | Simple checker for whether a 'GenericResult' is OK.
+isOk :: GenericResult a b -> Bool
isOk (Ok _) = True
-isOk _ = False
+isOk _ = False
--- | Simple checker for whether a 'Result' is a failure.
-isBad :: Result a -> Bool
+-- | Simple checker for whether a 'GenericResult' is a failure.
+isBad :: GenericResult a b -> Bool
isBad = not . isOk
--- | Converter from Either String to 'Result'.
-eitherToResult :: Either String a -> Result a
-eitherToResult (Left s) = Bad s
-eitherToResult (Right v) = Ok v
+-- | Converter from Either to 'GenericResult'.
+eitherToResult :: Either a b -> GenericResult a b
+eitherToResult (Left s) = Bad s
+eitherToResult (Right v) = Ok v
-- | Annotate a Result with an ownership information.
annotateResult :: String -> Result a -> Result a
annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
annotateResult _ v = v
+
+-- | Annotates and transforms IOErrors into a Result type. This can be
+-- used in the error handler argument to 'catch', for example.
+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
projects / ganeti-local / blobdiff