root / htools / Ganeti / BasicTypes.hs @ 25779212
History | View | Annotate | Download (5.9 kB)
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 |
, isOk |
25 |
, isBad |
26 |
, eitherToResult |
27 |
, annotateResult |
28 |
, annotateIOError |
29 |
, select |
30 |
, LookupResult(..) |
31 |
, MatchPriority(..) |
32 |
, lookupName |
33 |
, goodLookupResult |
34 |
, goodMatchPriority |
35 |
, prefixMatch |
36 |
, compareNameComponent |
37 |
) where |
38 |
|
39 |
import Control.Applicative |
40 |
import Control.Monad |
41 |
import Data.Function |
42 |
import Data.List |
43 |
|
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 |
46 |
-- mini-library here. |
47 |
-- |
48 |
-- The failure value for this monad is simply a string. |
49 |
data Result a |
50 |
= Bad String |
51 |
| Ok a |
52 |
deriving (Show, Read, Eq) |
53 |
|
54 |
instance Monad Result where |
55 |
(>>=) (Bad x) _ = Bad x |
56 |
(>>=) (Ok x) fn = fn x |
57 |
return = Ok |
58 |
fail = Bad |
59 |
|
60 |
instance Functor Result where |
61 |
fmap _ (Bad msg) = Bad msg |
62 |
fmap fn (Ok val) = Ok (fn val) |
63 |
|
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 |
67 |
-- error descriptions |
68 |
(Bad x) `mplus` (Bad y) = Bad (x ++ "; " ++ y) |
69 |
(Bad _) `mplus` x = x |
70 |
x@(Ok _) `mplus` _ = x |
71 |
|
72 |
instance Applicative Result where |
73 |
pure = Ok |
74 |
(Bad f) <*> _ = Bad f |
75 |
_ <*> (Bad x) = Bad x |
76 |
(Ok f) <*> (Ok x) = Ok $ f x |
77 |
|
78 |
-- | Simple checker for whether a 'Result' is OK. |
79 |
isOk :: Result a -> Bool |
80 |
isOk (Ok _) = True |
81 |
isOk _ = False |
82 |
|
83 |
-- | Simple checker for whether a 'Result' is a failure. |
84 |
isBad :: Result a -> Bool |
85 |
isBad = not . isOk |
86 |
|
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 |
91 |
|
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 |
96 |
|
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 |
102 |
|
103 |
-- * Misc functionality |
104 |
|
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 |
110 |
|
111 |
-- * Lookup of partial names functionality |
112 |
|
113 |
-- | The priority of a match in a lookup result. |
114 |
data MatchPriority = ExactMatch |
115 |
| MultipleMatch |
116 |
| PartialMatch |
117 |
| FailMatch |
118 |
deriving (Show, Read, Enum, Eq, Ord) |
119 |
|
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) |
126 |
|
127 |
-- | Lookup results have an absolute preference ordering. |
128 |
instance Eq LookupResult where |
129 |
(==) = (==) `on` lrMatchPriority |
130 |
|
131 |
instance Ord LookupResult where |
132 |
compare = compare `on` lrMatchPriority |
133 |
|
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 . (++ ".") |
141 |
|
142 |
-- | Is the lookup priority a "good" one? |
143 |
goodMatchPriority :: MatchPriority -> Bool |
144 |
goodMatchPriority ExactMatch = True |
145 |
goodMatchPriority PartialMatch = True |
146 |
goodMatchPriority _ = False |
147 |
|
148 |
-- | Is the lookup result an actual match? |
149 |
goodLookupResult :: LookupResult -> Bool |
150 |
goodLookupResult = goodMatchPriority . lrMatchPriority |
151 |
|
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) |
160 |
] |
161 |
|
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 |
169 |
select (min new old) |
170 |
-- special cases: |
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] |
177 |
|
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 |