3 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
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.
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.
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
22 module Ganeti.BasicTypes
36 , compareNameComponent
39 import Control.Applicative
44 -- | This is similar to the JSON library Result type - /very/ similar,
45 -- but we want to use it in multiple places, so we abstract it into a
48 -- The failure value for this monad is simply a string.
52 deriving (Show, Read, Eq)
54 instance Monad Result where
55 (>>=) (Bad x) _ = Bad x
56 (>>=) (Ok x) fn = fn x
60 instance Functor Result where
61 fmap _ (Bad msg) = Bad msg
62 fmap fn (Ok val) = Ok (fn val)
64 instance MonadPlus Result where
65 mzero = Bad "zero Result when used as MonadPlus"
66 -- for mplus, when we 'add' two Bad values, we concatenate their
68 (Bad x) `mplus` (Bad y) = Bad (x ++ "; " ++ y)
70 x@(Ok _) `mplus` _ = x
72 instance Applicative Result where
76 (Ok f) <*> (Ok x) = Ok $ f x
78 -- | Simple checker for whether a 'Result' is OK.
79 isOk :: Result a -> Bool
83 -- | Simple checker for whether a 'Result' is a failure.
84 isBad :: Result a -> Bool
87 -- | Converter from Either String to 'Result'.
88 eitherToResult :: Either String a -> Result a
89 eitherToResult (Left s) = Bad s
90 eitherToResult (Right v) = Ok v
92 -- | Annotate a Result with an ownership information.
93 annotateResult :: String -> Result a -> Result a
94 annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
95 annotateResult _ v = v
97 -- | Annotates and transforms IOErrors into a Result type. This can be
98 -- used in the error handler argument to 'catch', for example.
99 annotateIOError :: String -> IOError -> IO (Result a)
100 annotateIOError description exc =
101 return . Bad $ description ++ ": " ++ show exc
103 -- * Misc functionality
105 -- | Return the first result with a True condition, or the default otherwise.
106 select :: a -- ^ default result
107 -> [(Bool, a)] -- ^ list of \"condition, result\"
108 -> a -- ^ first result which has a True condition, or default
109 select def = maybe def snd . find fst
111 -- * Lookup of partial names functionality
113 -- | The priority of a match in a lookup result.
114 data MatchPriority = ExactMatch
118 deriving (Show, Read, Enum, Eq, Ord)
120 -- | The result of a name lookup in a list.
121 data LookupResult = LookupResult
122 { lrMatchPriority :: MatchPriority -- ^ The result type
123 -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
124 , lrContent :: String
125 } deriving (Show, Read)
127 -- | Lookup results have an absolute preference ordering.
128 instance Eq LookupResult where
129 (==) = (==) `on` lrMatchPriority
131 instance Ord LookupResult where
132 compare = compare `on` lrMatchPriority
134 -- | Check for prefix matches in names.
135 -- Implemented in Ganeti core utils.text.MatchNameComponent
136 -- as the regexp r"^%s(\..*)?$" % re.escape(key)
137 prefixMatch :: String -- ^ Lookup
138 -> String -- ^ Full name
139 -> Bool -- ^ Whether there is a prefix match
140 prefixMatch = isPrefixOf . (++ ".")
142 -- | Is the lookup priority a "good" one?
143 goodMatchPriority :: MatchPriority -> Bool
144 goodMatchPriority ExactMatch = True
145 goodMatchPriority PartialMatch = True
146 goodMatchPriority _ = False
148 -- | Is the lookup result an actual match?
149 goodLookupResult :: LookupResult -> Bool
150 goodLookupResult = goodMatchPriority . lrMatchPriority
152 -- | Compares a canonical name and a lookup string.
153 compareNameComponent :: String -- ^ Canonical (target) name
154 -> String -- ^ Partial (lookup) name
155 -> LookupResult -- ^ Result of the lookup
156 compareNameComponent cnl lkp =
157 select (LookupResult FailMatch lkp)
158 [ (cnl == lkp , LookupResult ExactMatch cnl)
159 , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)
162 -- | Lookup a string and choose the best result.
163 chooseLookupResult :: String -- ^ Lookup key
164 -> String -- ^ String to compare to the lookup key
165 -> LookupResult -- ^ Previous result
166 -> LookupResult -- ^ New result
167 chooseLookupResult lkp cstr old =
168 -- default: use class order to pick the minimum result
171 -- short circuit if the new result is an exact match
172 [ (lrMatchPriority new == ExactMatch, new)
173 -- if both are partial matches generate a multiple match
174 , (partial2, LookupResult MultipleMatch lkp)
175 ] where new = compareNameComponent cstr lkp
176 partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]
178 -- | Find the canonical name for a lookup string in a list of names.
179 lookupName :: [String] -- ^ List of keys
180 -> String -- ^ Lookup string
181 -> LookupResult -- ^ Result of the lookup
182 lookupName l s = foldr (chooseLookupResult s)
183 (LookupResult FailMatch s) l