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   , annotateIOError
  35   , select
  36   , LookupResult(..)
  37   , MatchPriority(..)
  38   , lookupName
  39   , goodLookupResult
  40   , goodMatchPriority
  41   , prefixMatch
  42   , compareNameComponent
  43   ) where
  44
  45 import Control.Applicative
  46 import Control.Monad
  47 import Control.Monad.Trans
  48 import Data.Function
  49 import Data.List
  50
  51 -- | Generic monad for our error handling mechanisms.
  52 data GenericResult a b
  53   = Bad a
  54   | Ok b
  55     deriving (Show, Read, Eq)
  56
  57 -- | Type alias for a string Result.
  58 type Result = GenericResult String
  59
  60 -- | Type class for things that can be built from strings.
  61 class FromString a where
  62   mkFromString :: String -> a
  63
  64 -- | Trivial 'String' instance; requires FlexibleInstances extension
  65 -- though.
  66 instance FromString [Char] where
  67   mkFromString = id
  68
  69 -- | 'Monad' instance for 'GenericResult'.
  70 instance (FromString a) => Monad (GenericResult a) where
  71   (>>=) (Bad x) _ = Bad x
  72   (>>=) (Ok x) fn = fn x
  73   return = Ok
  74   fail   = Bad . mkFromString
  75
  76 instance Functor (GenericResult a) where
  77   fmap _ (Bad msg) = Bad msg
  78   fmap fn (Ok val) = Ok (fn val)
  79
  80 instance MonadPlus (GenericResult String) where
  81   mzero = Bad "zero Result when used as MonadPlus"
  82   -- for mplus, when we 'add' two Bad values, we concatenate their
  83   -- error descriptions
  84   (Bad x) `mplus` (Bad y) = Bad (x ++ "; " ++ y)
  85   (Bad _) `mplus` x = x
  86   x@(Ok _) `mplus` _ = x
  87
  88 instance Applicative (GenericResult a) where
  89   pure = Ok
  90   (Bad f) <*> _       = Bad f
  91   _       <*> (Bad x) = Bad x
  92   (Ok f)  <*> (Ok x)  = Ok $ f x
  93
  94 -- | This is a monad transformation for Result. It's implementation is
  95 -- based on the implementations of MaybeT and ErrorT.
  96 newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)}
  97
  98 instance (Monad m, FromString a) => Monad (ResultT a m) where
  99   fail err = ResultT (return . Bad $ mkFromString err)
 100   return   = lift . return
 101   x >>= f  = ResultT $ do
 102                a <- runResultT x
 103                case a of
 104                  Ok val -> runResultT $ f val
 105                  Bad err -> return $ Bad err
 106
 107 instance MonadTrans (ResultT a) where
 108   lift x = ResultT (liftM Ok x)
 109
 110 instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where
 111   liftIO = lift . liftIO
 112
 113 -- | Lift a `Result` value to a `ResultT`.
 114 resultT :: Monad m => GenericResult a b -> ResultT a m b
 115 resultT = ResultT . return
 116
 117 -- | Simple checker for whether a 'GenericResult' is OK.
 118 isOk :: GenericResult a b -> Bool
 119 isOk (Ok _) = True
 120 isOk _      = False
 121
 122 -- | Simple checker for whether a 'GenericResult' is a failure.
 123 isBad :: GenericResult a b -> Bool
 124 isBad = not . isOk
 125
 126 -- | Converter from Either String to 'GeneicResult'.
 127 eitherToResult :: Either a b -> GenericResult a b
 128 eitherToResult (Left  s) = Bad s
 129 eitherToResult (Right v) = Ok  v
 130
 131 -- | Annotate a Result with an ownership information.
 132 annotateResult :: String -> Result a -> Result a
 133 annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
 134 annotateResult _ v = v
 135
 136 -- | Annotates and transforms IOErrors into a Result type. This can be
 137 -- used in the error handler argument to 'catch', for example.
 138 annotateIOError :: String -> IOError -> IO (Result a)
 139 annotateIOError description exc =
 140   return . Bad $ description ++ ": " ++ show exc
 141
 142 -- * Misc functionality
 143
 144 -- | Return the first result with a True condition, or the default otherwise.
 145 select :: a            -- ^ default result
 146        -> [(Bool, a)]  -- ^ list of \"condition, result\"
 147        -> a            -- ^ first result which has a True condition, or default
 148 select def = maybe def snd . find fst
 149
 150 -- * Lookup of partial names functionality
 151
 152 -- | The priority of a match in a lookup result.
 153 data MatchPriority = ExactMatch
 154                    | MultipleMatch
 155                    | PartialMatch
 156                    | FailMatch
 157                    deriving (Show, Read, Enum, Eq, Ord)
 158
 159 -- | The result of a name lookup in a list.
 160 data LookupResult = LookupResult
 161   { lrMatchPriority :: MatchPriority -- ^ The result type
 162   -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
 163   , lrContent :: String
 164   } deriving (Show, Read)
 165
 166 -- | Lookup results have an absolute preference ordering.
 167 instance Eq LookupResult where
 168   (==) = (==) `on` lrMatchPriority
 169
 170 instance Ord LookupResult where
 171   compare = compare `on` lrMatchPriority
 172
 173 -- | Check for prefix matches in names.
 174 -- Implemented in Ganeti core utils.text.MatchNameComponent
 175 -- as the regexp r"^%s(\..*)?$" % re.escape(key)
 176 prefixMatch :: String  -- ^ Lookup
 177             -> String  -- ^ Full name
 178             -> Bool    -- ^ Whether there is a prefix match
 179 prefixMatch = isPrefixOf . (++ ".")
 180
 181 -- | Is the lookup priority a "good" one?
 182 goodMatchPriority :: MatchPriority -> Bool
 183 goodMatchPriority ExactMatch = True
 184 goodMatchPriority PartialMatch = True
 185 goodMatchPriority _ = False
 186
 187 -- | Is the lookup result an actual match?
 188 goodLookupResult :: LookupResult -> Bool
 189 goodLookupResult = goodMatchPriority . lrMatchPriority
 190
 191 -- | Compares a canonical name and a lookup string.
 192 compareNameComponent :: String        -- ^ Canonical (target) name
 193                      -> String        -- ^ Partial (lookup) name
 194                      -> LookupResult  -- ^ Result of the lookup
 195 compareNameComponent cnl lkp =
 196   select (LookupResult FailMatch lkp)
 197   [ (cnl == lkp          , LookupResult ExactMatch cnl)
 198   , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)
 199   ]
 200
 201 -- | Lookup a string and choose the best result.
 202 chooseLookupResult :: String       -- ^ Lookup key
 203                    -> String       -- ^ String to compare to the lookup key
 204                    -> LookupResult -- ^ Previous result
 205                    -> LookupResult -- ^ New result
 206 chooseLookupResult lkp cstr old =
 207   -- default: use class order to pick the minimum result
 208   select (min new old)
 209   -- special cases:
 210   -- short circuit if the new result is an exact match
 211   [ (lrMatchPriority new == ExactMatch, new)
 212   -- if both are partial matches generate a multiple match
 213   , (partial2, LookupResult MultipleMatch lkp)
 214   ] where new = compareNameComponent cstr lkp
 215           partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]
 216
 217 -- | Find the canonical name for a lookup string in a list of names.
 218 lookupName :: [String]      -- ^ List of keys
 219            -> String        -- ^ Lookup string
 220            -> LookupResult  -- ^ Result of the lookup
 221 lookupName l s = foldr (chooseLookupResult s)
 222                        (LookupResult FailMatch s) l