code.grnet.gr Git - ganeti-local/blob - htools/Ganeti/BasicTypes.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2
   3 {-
   4
   5 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
   6
   7 This program is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2 of the License, or
  10 (at your option) any later version.
  11
  12 This program is distributed in the hope that it will be useful, but
  13 WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with this program; if not, write to the Free Software
  19 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  20 02110-1301, USA.
  21
  22 -}
  23
  24 module Ganeti.BasicTypes
  25   ( GenericResult(..)
  26   , Result
  27   , ResultT(..)
  28   , resultT
  29   , FromString(..)
  30   , isOk
  31   , isBad
  32   , eitherToResult
  33   , annotateResult
  34   , select
  35   , LookupResult(..)
  36   , MatchPriority(..)
  37   , lookupName
  38   , goodLookupResult
  39   , goodMatchPriority
  40   , prefixMatch
  41   , compareNameComponent
  42   ) where
  43
  44 import Control.Applicative
  45 import Control.Monad
  46 import Control.Monad.Trans
  47 import Data.Function
  48 import Data.List
  49
  50 -- | Generic monad for our error handling mechanisms.
  51 data GenericResult a b
  52   = Bad a
  53   | Ok b
  54     deriving (Show, Eq)
  55
  56 -- | Type alias for a string Result.
  57 type Result = GenericResult String
  58
  59 -- | Type class for things that can be built from strings.
  60 class FromString a where
  61   mkFromString :: String -> a
  62
  63 -- | Trivial 'String' instance; requires FlexibleInstances extension
  64 -- though.
  65 instance FromString [Char] where
  66   mkFromString = id
  67
  68 -- | 'Monad' instance for 'GenericResult'.
  69 instance (FromString a) => Monad (GenericResult a) where
  70   (>>=) (Bad x) _ = Bad x
  71   (>>=) (Ok x) fn = fn x
  72   return = Ok
  73   fail   = Bad . mkFromString
  74
  75 instance Functor (GenericResult a) where
  76   fmap _ (Bad msg) = Bad msg
  77   fmap fn (Ok val) = Ok (fn val)
  78
  79 instance MonadPlus (GenericResult String) where
  80   mzero = Bad "zero Result when used as MonadPlus"
  81   -- for mplus, when we 'add' two Bad values, we concatenate their
  82   -- error descriptions
  83   (Bad x) `mplus` (Bad y) = Bad (x ++ "; " ++ y)
  84   (Bad _) `mplus` x = x
  85   x@(Ok _) `mplus` _ = x
  86
  87 instance Applicative (GenericResult a) where
  88   pure = Ok
  89   (Bad f) <*> _       = Bad f
  90   _       <*> (Bad x) = Bad x
  91   (Ok f)  <*> (Ok x)  = Ok $ f x
  92
  93 -- | This is a monad transformation for Result. It's implementation is
  94 -- based on the implementations of MaybeT and ErrorT.
  95 newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)}
  96
  97 instance (Monad m, FromString a) => Monad (ResultT a m) where
  98   fail err = ResultT (return . Bad $ mkFromString err)
  99   return   = lift . return
 100   x >>= f  = ResultT $ do
 101                a <- runResultT x
 102                case a of
 103                  Ok val -> runResultT $ f val
 104                  Bad err -> return $ Bad err
 105
 106 instance MonadTrans (ResultT a) where
 107   lift x = ResultT (liftM Ok x)
 108
 109 instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where
 110   liftIO = lift . liftIO
 111
 112 -- | Lift a `Result` value to a `ResultT`.
 113 resultT :: Monad m => GenericResult a b -> ResultT a m b
 114 resultT = ResultT . return
 115
 116 -- | Simple checker for whether a 'GenericResult' is OK.
 117 isOk :: GenericResult a b -> Bool
 118 isOk (Ok _) = True
 119 isOk _      = False
 120
 121 -- | Simple checker for whether a 'GenericResult' is a failure.
 122 isBad :: GenericResult a b -> Bool
 123 isBad = not . isOk
 124
 125 -- | Converter from Either to 'GenericResult'.
 126 eitherToResult :: Either a b -> GenericResult a b
 127 eitherToResult (Left  s) = Bad s
 128 eitherToResult (Right v) = Ok  v
 129
 130 -- | Annotate a Result with an ownership information.
 131 annotateResult :: String -> Result a -> Result a
 132 annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
 133 annotateResult _ v = v
 134
 135 -- * Misc functionality
 136
 137 -- | Return the first result with a True condition, or the default otherwise.
 138 select :: a            -- ^ default result
 139        -> [(Bool, a)]  -- ^ list of \"condition, result\"
 140        -> a            -- ^ first result which has a True condition, or default
 141 select def = maybe def snd . find fst
 142
 143 -- * Lookup of partial names functionality
 144
 145 -- | The priority of a match in a lookup result.
 146 data MatchPriority = ExactMatch
 147                    | MultipleMatch
 148                    | PartialMatch
 149                    | FailMatch
 150                    deriving (Show, Enum, Eq, Ord)
 151
 152 -- | The result of a name lookup in a list.
 153 data LookupResult = LookupResult
 154   { lrMatchPriority :: MatchPriority -- ^ The result type
 155   -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
 156   , lrContent :: String
 157   } deriving (Show)
 158
 159 -- | Lookup results have an absolute preference ordering.
 160 instance Eq LookupResult where
 161   (==) = (==) `on` lrMatchPriority
 162
 163 instance Ord LookupResult where
 164   compare = compare `on` lrMatchPriority
 165
 166 -- | Check for prefix matches in names.
 167 -- Implemented in Ganeti core utils.text.MatchNameComponent
 168 -- as the regexp r"^%s(\..*)?$" % re.escape(key)
 169 prefixMatch :: String  -- ^ Lookup
 170             -> String  -- ^ Full name
 171             -> Bool    -- ^ Whether there is a prefix match
 172 prefixMatch = isPrefixOf . (++ ".")
 173
 174 -- | Is the lookup priority a "good" one?
 175 goodMatchPriority :: MatchPriority -> Bool
 176 goodMatchPriority ExactMatch = True
 177 goodMatchPriority PartialMatch = True
 178 goodMatchPriority _ = False
 179
 180 -- | Is the lookup result an actual match?
 181 goodLookupResult :: LookupResult -> Bool
 182 goodLookupResult = goodMatchPriority . lrMatchPriority
 183
 184 -- | Compares a canonical name and a lookup string.
 185 compareNameComponent :: String        -- ^ Canonical (target) name
 186                      -> String        -- ^ Partial (lookup) name
 187                      -> LookupResult  -- ^ Result of the lookup
 188 compareNameComponent cnl lkp =
 189   select (LookupResult FailMatch lkp)
 190   [ (cnl == lkp          , LookupResult ExactMatch cnl)
 191   , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)
 192   ]
 193
 194 -- | Lookup a string and choose the best result.
 195 chooseLookupResult :: String       -- ^ Lookup key
 196                    -> String       -- ^ String to compare to the lookup key
 197                    -> LookupResult -- ^ Previous result
 198                    -> LookupResult -- ^ New result
 199 chooseLookupResult lkp cstr old =
 200   -- default: use class order to pick the minimum result
 201   select (min new old)
 202   -- special cases:
 203   -- short circuit if the new result is an exact match
 204   [ (lrMatchPriority new == ExactMatch, new)
 205   -- if both are partial matches generate a multiple match
 206   , (partial2, LookupResult MultipleMatch lkp)
 207   ] where new = compareNameComponent cstr lkp
 208           partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]
 209
 210 -- | Find the canonical name for a lookup string in a list of names.
 211 lookupName :: [String]      -- ^ List of keys
 212            -> String        -- ^ Lookup string
 213            -> LookupResult  -- ^ Result of the lookup
 214 lookupName l s = foldr (chooseLookupResult s)
 215                        (LookupResult FailMatch s) l