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

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