Merge branch 'stable-2.16' into stable-2.17
[ganeti-github.git] / src / Ganeti / BasicTypes.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE TypeFamilies #-}
5 {-# LANGUAGE DeriveFunctor #-}
6 {-# LANGUAGE UndecidableInstances #-}
7 {-# LANGUAGE CPP #-}
8
9 {-
10
11 Copyright (C) 2009, 2010, 2011, 2012, 2015 Google Inc.
12 All rights reserved.
13
14 Redistribution and use in source and binary forms, with or without
15 modification, are permitted provided that the following conditions are
16 met:
17
18 1. Redistributions of source code must retain the above copyright notice,
19 this list of conditions and the following disclaimer.
20
21 2. Redistributions in binary form must reproduce the above copyright
22 notice, this list of conditions and the following disclaimer in the
23 documentation and/or other materials provided with the distribution.
24
25 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
26 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
27 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
29 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
32 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
33 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
34 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
35 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36
37 -}
38
39 module Ganeti.BasicTypes
40 ( GenericResult(..)
41 , genericResult
42 , Result
43 , ResultT(..)
44 , mkResultT
45 , mkResultT'
46 , mkResultTEither
47 , withError
48 , withErrorT
49 , toError
50 , toErrorBase
51 , toErrorStr
52 , tryError
53 , Error(..) -- re-export from Control.Monad.Error
54 , MonadIO(..) -- re-export from Control.Monad.IO.Class
55 , FromString(..)
56 , isOk
57 , isBad
58 , justOk
59 , justBad
60 , eitherToResult
61 , isLeft
62 , isRight
63 , annotateResult
64 , annotateError
65 , failError
66 , catchErrorT
67 , handleErrorT
68 , orElse
69 , iterateOk
70 , select
71 , runListHead
72 , LookupResult(..)
73 , MatchPriority(..)
74 , lookupName
75 , goodLookupResult
76 , goodMatchPriority
77 , prefixMatch
78 , compareNameComponent
79 , ListSet(..)
80 , emptyListSet
81 , Down(..)
82 ) where
83
84 import Prelude ()
85 import Ganeti.Prelude
86
87 import Control.Applicative
88 import Control.Exception (try)
89 import Control.Monad
90 import Control.Monad.Base
91 import Control.Monad.Error.Class
92 import Control.Monad.Trans
93 import Control.Monad.Trans.Control
94 import Data.Function
95 import Data.List (find, isPrefixOf)
96 import Data.Maybe
97 import Data.Set (Set)
98 import qualified Data.Set as Set (empty)
99 import Text.JSON (JSON)
100 import qualified Text.JSON as JSON (readJSON, showJSON)
101 #if MIN_VERSION_base(4,6,0)
102 import Data.Ord
103 #endif
104
105 -- Remove after we require >= 1.8.58
106 -- See: https://github.com/ndmitchell/hlint/issues/24
107 {-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-}
108
109 -- | Generic monad for our error handling mechanisms.
110 data GenericResult a b
111 = Bad a
112 | Ok b
113 deriving (Show, Eq)
114
115 -- | Sum type structure of GenericResult.
116 genericResult :: (a -> c) -> (b -> c) -> GenericResult a b -> c
117 genericResult f _ (Bad a) = f a
118 genericResult _ g (Ok b) = g b
119 {-# INLINE genericResult #-}
120
121 -- | Type alias for a string Result.
122 type Result = GenericResult String
123
124 -- | Type class for things that can be built from strings.
125 class FromString a where
126 mkFromString :: String -> a
127
128 -- | Trivial 'String' instance; requires FlexibleInstances extension
129 -- though.
130 instance FromString [Char] where
131 mkFromString = id
132
133 instance FromString IOError where
134 mkFromString = userError
135
136 -- | 'Monad' instance for 'GenericResult'.
137 instance (FromString a) => Monad (GenericResult a) where
138 (>>=) (Bad x) _ = Bad x
139 (>>=) (Ok x) fn = fn x
140 return = Ok
141 fail = Bad . mkFromString
142
143 instance Functor (GenericResult a) where
144 fmap _ (Bad msg) = Bad msg
145 fmap fn (Ok val) = Ok (fn val)
146
147 instance (FromString a, Monoid a) => Alternative (GenericResult a) where
148 empty = Bad $ mkFromString "zero Result when used as empty"
149 -- for mplus, when we 'add' two Bad values, we concatenate their
150 -- error descriptions
151 (Bad x) <|> (Bad y) = Bad (x `mappend` mkFromString "; " `mappend` y)
152 (Bad _) <|> x = x
153 x@(Ok _) <|> _ = x
154
155 instance (FromString a, Monoid a) => MonadPlus (GenericResult a) where
156 mzero = empty
157 mplus = (<|>)
158
159 instance (FromString a) => MonadError a (GenericResult a) where
160 throwError = Bad
161 {-# INLINE throwError #-}
162 catchError x h = genericResult h (const x) x
163 {-# INLINE catchError #-}
164
165 instance Applicative (GenericResult a) where
166 pure = Ok
167 (Bad f) <*> _ = Bad f
168 _ <*> (Bad x) = Bad x
169 (Ok f) <*> (Ok x) = Ok $ f x
170
171 -- | This is a monad transformation for Result. It's implementation is
172 -- based on the implementations of MaybeT and ErrorT.
173 --
174 -- 'ResultT' is very similar to @ErrorT@, but with one subtle difference:
175 -- If 'mplus' combines two failing operations, errors of both of them
176 -- are combined.
177 newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)}
178
179 -- | Eliminates a 'ResultT' value given appropriate continuations
180 elimResultT :: (Monad m)
181 => (a -> ResultT a' m b')
182 -> (b -> ResultT a' m b')
183 -> ResultT a m b
184 -> ResultT a' m b'
185 elimResultT l r = ResultT . (runResultT . result <=< runResultT)
186 where
187 result (Ok x) = r x
188 result (Bad e) = l e
189 {-# INLINE elimResultT #-}
190
191 instance (Monad m) => Functor (ResultT a m) where
192 fmap f = ResultT . liftM (fmap f) . runResultT
193
194 instance (Monad m, FromString a) => Applicative (ResultT a m) where
195 pure = return
196 (<*>) = ap
197
198 instance (Monad m, FromString a) => Monad (ResultT a m) where
199 fail err = ResultT (return . Bad $ mkFromString err)
200 return = lift . return
201 (>>=) = flip (elimResultT throwError)
202
203 instance (Monad m, FromString a) => MonadError a (ResultT a m) where
204 throwError = ResultT . return . Bad
205 catchError = catchErrorT
206
207 instance MonadTrans (ResultT a) where
208 lift = ResultT . liftM Ok
209
210 -- | The instance catches any 'IOError' using 'try' and converts it into an
211 -- error message using 'mkFromString'.
212 --
213 -- This way, monadic code within 'ResultT' that uses solely 'liftIO' to
214 -- include 'IO' actions ensures that all IO exceptions are handled.
215 --
216 -- Other exceptions (see instances of 'Exception') are not currently handled.
217 -- This might be revised in the future.
218 instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where
219 liftIO = ResultT . liftIO
220 . liftM (either (failError . show) return)
221 . (try :: IO a -> IO (Either IOError a))
222
223 instance (MonadBase IO m, FromString a) => MonadBase IO (ResultT a m) where
224 liftBase = ResultT . liftBase
225 . liftM (either (failError . show) return)
226 . (try :: IO a -> IO (Either IOError a))
227
228 instance (FromString a) => MonadTransControl (ResultT a) where
229 #if MIN_VERSION_monad_control(1,0,0)
230 -- Needs Undecidable instances
231 type StT (ResultT a) b = GenericResult a b
232 liftWith f = ResultT . liftM return $ f runResultT
233 restoreT = ResultT
234 #else
235 newtype StT (ResultT a) b = StResultT { runStResultT :: GenericResult a b }
236 liftWith f = ResultT . liftM return $ f (liftM StResultT . runResultT)
237 restoreT = ResultT . liftM runStResultT
238 #endif
239 {-# INLINE liftWith #-}
240 {-# INLINE restoreT #-}
241
242 instance (FromString a, MonadBaseControl IO m)
243 => MonadBaseControl IO (ResultT a m) where
244 #if MIN_VERSION_monad_control(1,0,0)
245 -- Needs Undecidable instances
246 type StM (ResultT a m) b
247 = ComposeSt (ResultT a) m b
248 liftBaseWith = defaultLiftBaseWith
249 restoreM = defaultRestoreM
250 #else
251 newtype StM (ResultT a m) b
252 = StMResultT { runStMResultT :: ComposeSt (ResultT a) m b }
253 liftBaseWith = defaultLiftBaseWith StMResultT
254 restoreM = defaultRestoreM runStMResultT
255 #endif
256 {-# INLINE liftBaseWith #-}
257 {-# INLINE restoreM #-}
258
259 instance (Monad m, FromString a, Monoid a)
260 => Alternative (ResultT a m) where
261 empty = ResultT $ return mzero
262 -- Ensure that 'y' isn't run if 'x' contains a value. This makes it a bit
263 -- more complicated than 'mplus' of 'GenericResult'.
264 x <|> y = elimResultT combine return x
265 where combine x' = ResultT $ liftM (mplus (Bad x')) (runResultT y)
266
267 instance (Monad m, FromString a, Monoid a)
268 => MonadPlus (ResultT a m) where
269 mzero = empty
270 mplus = (<|>)
271
272 -- | Changes the error message of a result value, if present.
273 -- Note that since 'GenericResult' is also a 'MonadError', this function
274 -- is a generalization of
275 -- @(Error e') => (e' -> e) -> GenericResult e' a -> GenericResult e a@
276 withError :: (MonadError e m) => (e' -> e) -> GenericResult e' a -> m a
277 withError f = genericResult (throwError . f) return
278
279 -- | Changes the error message of a @ResultT@ value, if present.
280 withErrorT :: (Monad m, FromString e)
281 => (e' -> e) -> ResultT e' m a -> ResultT e m a
282 withErrorT f = ResultT . liftM (withError f) . runResultT
283
284 -- | Lift a 'Result' value to any 'MonadError'. Since 'ResultT' is itself its
285 -- instance, it's a generalization of
286 -- @Monad m => GenericResult a b -> ResultT a m b@.
287 toError :: (MonadError e m) => GenericResult e a -> m a
288 toError = genericResult throwError return
289 {-# INLINE toError #-}
290
291 -- | Lift a 'ResultT' value into any 'MonadError' with the same base monad.
292 toErrorBase :: (MonadBase b m, MonadError e m) => ResultT e b a -> m a
293 toErrorBase = (toError =<<) . liftBase . runResultT
294 {-# INLINE toErrorBase #-}
295
296 -- | An alias for @withError mkFromString@, which is often
297 -- used to lift a pure error to a monad stack. See also 'annotateResult'.
298 toErrorStr :: (MonadError e m, FromString e) => Result a -> m a
299 toErrorStr = withError mkFromString
300
301 -- | Run a given computation and if an error occurs, return it as `Left` of
302 -- `Either`.
303 -- This is a generalized version of 'try'.
304 tryError :: (MonadError e m) => m a -> m (Either e a)
305 tryError = flip catchError (return . Left) . liftM Right
306 {-# INLINE tryError #-}
307
308 -- | Converts a monadic result with a 'String' message into
309 -- a 'ResultT' with an arbitrary 'Error'.
310 --
311 -- Expects that the given action has already taken care of any possible
312 -- errors. In particular, if applied on @IO (Result a)@, any exceptions
313 -- should be handled by the given action.
314 --
315 -- See also 'toErrorStr'.
316 mkResultT :: (Monad m, FromString e) => m (Result a) -> ResultT e m a
317 mkResultT = ResultT . liftM toErrorStr
318
319 -- | Generalisation of mkResultT accepting any showable failures.
320 mkResultT' :: (Monad m, FromString e, Show s)
321 => m (GenericResult s a) -> ResultT e m a
322 mkResultT' = mkResultT . liftM (genericResult (Bad . show) Ok)
323
324 -- | Generalisation of mkResultT accepting any showable failures.
325 mkResultTEither :: (Monad m, FromString e, Show s)
326 => m (Either s a) -> ResultT e m a
327 mkResultTEither = mkResultT . liftM (either (Bad . show) Ok)
328
329 -- | Simple checker for whether a 'GenericResult' is OK.
330 isOk :: GenericResult a b -> Bool
331 isOk (Ok _) = True
332 isOk _ = False
333
334 -- | Simple checker for whether a 'GenericResult' is a failure.
335 isBad :: GenericResult a b -> Bool
336 isBad = not . isOk
337
338 -- | Simple filter returning only OK values of GenericResult
339 justOk :: [GenericResult a b] -> [b]
340 justOk = mapMaybe (genericResult (const Nothing) Just)
341
342 -- | Simple filter returning only Bad values of GenericResult
343 justBad :: [GenericResult a b] -> [a]
344 justBad = mapMaybe (genericResult Just (const Nothing))
345
346 -- | Converter from Either to 'GenericResult'.
347 eitherToResult :: Either a b -> GenericResult a b
348 eitherToResult (Left s) = Bad s
349 eitherToResult (Right v) = Ok v
350
351 -- | Check if an either is Left. Equivalent to isLeft from Data.Either
352 -- version 4.7.0.0 or higher.
353 isLeft :: Either a b -> Bool
354 isLeft (Left _) = True
355 isLeft _ = False
356
357 -- | Check if an either is Right. Equivalent to isRight from Data.Either
358 -- version 4.7.0.0 or higher.
359 isRight :: Either a b -> Bool
360 isRight = not . isLeft
361
362 -- | Annotate an error with an ownership information, lifting it to a
363 -- 'MonadError'. Since 'Result' is an instance of 'MonadError' itself,
364 -- it's a generalization of type @String -> Result a -> Result a@.
365 -- See also 'toErrorStr'.
366 annotateResult :: (MonadError e m, FromString e) => String -> Result a -> m a
367 annotateResult owner = toErrorStr . annotateError owner
368
369 -- | Annotate an error with an ownership information inside a 'MonadError'.
370 -- See also 'annotateResult'.
371 annotateError :: (MonadError e m, FromString e, Monoid e)
372 => String -> m a -> m a
373 annotateError owner =
374 flip catchError (throwError . mappend (mkFromString $ owner ++ ": "))
375 {-# INLINE annotateError #-}
376
377 -- | Throws a 'String' message as an error in a 'MonadError'.
378 -- This is a generalization of 'Bad'.
379 -- It's similar to 'fail', but works within a 'MonadError', avoiding the
380 -- unsafe nature of 'fail'.
381 failError :: (MonadError e m, FromString e) => String -> m a
382 failError = throwError . mkFromString
383
384 -- | A synonym for @flip@ 'catchErrorT'.
385 handleErrorT :: (Monad m, FromString e)
386 => (e' -> ResultT e m a) -> ResultT e' m a -> ResultT e m a
387 handleErrorT handler = elimResultT handler return
388 {-# INLINE handleErrorT #-}
389
390 -- | Catches an error in a @ResultT@ value. This is similar to 'catchError',
391 -- but in addition allows to change the error type.
392 catchErrorT :: (Monad m, FromString e)
393 => ResultT e' m a -> (e' -> ResultT e m a) -> ResultT e m a
394 catchErrorT = flip handleErrorT
395 {-# INLINE catchErrorT #-}
396
397 -- | If the first computation fails, run the second one.
398 -- Unlike 'mplus' instance for 'ResultT', this doesn't require
399 -- the 'Monoid' constrait.
400 orElse :: (MonadError e m) => m a -> m a -> m a
401 orElse x y = catchError x (const y)
402
403 -- | Iterate while Ok.
404 iterateOk :: (a -> GenericResult b a) -> a -> [a]
405 iterateOk f a = genericResult (const []) ((:) a . iterateOk f) (f a)
406
407 -- * Misc functionality
408
409 -- | Return the first result with a True condition, or the default otherwise.
410 select :: a -- ^ default result
411 -> [(Bool, a)] -- ^ list of \"condition, result\"
412 -> a -- ^ first result which has a True condition, or default
413 select def = maybe def snd . find fst
414
415 -- | Apply a function to the first element of a list, return the default
416 -- value, if the list is empty. This is just a convenient combination of
417 -- maybe and listToMaybe.
418 runListHead :: a -> (b -> a) -> [b] -> a
419 runListHead a f = maybe a f . listToMaybe
420
421 -- * Lookup of partial names functionality
422
423 -- | The priority of a match in a lookup result.
424 data MatchPriority = ExactMatch
425 | MultipleMatch
426 | PartialMatch
427 | FailMatch
428 deriving (Show, Enum, Eq, Ord)
429
430 -- | The result of a name lookup in a list.
431 data LookupResult = LookupResult
432 { lrMatchPriority :: MatchPriority -- ^ The result type
433 -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
434 , lrContent :: String
435 } deriving (Show)
436
437 -- | Lookup results have an absolute preference ordering.
438 instance Eq LookupResult where
439 (==) = (==) `on` lrMatchPriority
440
441 instance Ord LookupResult where
442 compare = compare `on` lrMatchPriority
443
444 -- | Check for prefix matches in names.
445 -- Implemented in Ganeti core utils.text.MatchNameComponent
446 -- as the regexp r"^%s(\..*)?$" % re.escape(key)
447 prefixMatch :: String -- ^ Lookup
448 -> String -- ^ Full name
449 -> Bool -- ^ Whether there is a prefix match
450 prefixMatch = isPrefixOf . (++ ".")
451
452 -- | Is the lookup priority a "good" one?
453 goodMatchPriority :: MatchPriority -> Bool
454 goodMatchPriority ExactMatch = True
455 goodMatchPriority PartialMatch = True
456 goodMatchPriority _ = False
457
458 -- | Is the lookup result an actual match?
459 goodLookupResult :: LookupResult -> Bool
460 goodLookupResult = goodMatchPriority . lrMatchPriority
461
462 -- | Compares a canonical name and a lookup string.
463 compareNameComponent :: String -- ^ Canonical (target) name
464 -> String -- ^ Partial (lookup) name
465 -> LookupResult -- ^ Result of the lookup
466 compareNameComponent cnl lkp =
467 select (LookupResult FailMatch lkp)
468 [ (cnl == lkp , LookupResult ExactMatch cnl)
469 , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)
470 ]
471
472 -- | Lookup a string and choose the best result.
473 chooseLookupResult :: String -- ^ Lookup key
474 -> String -- ^ String to compare to the lookup key
475 -> LookupResult -- ^ Previous result
476 -> LookupResult -- ^ New result
477 chooseLookupResult lkp cstr old =
478 -- default: use class order to pick the minimum result
479 select (min new old)
480 -- special cases:
481 -- short circuit if the new result is an exact match
482 [ (lrMatchPriority new == ExactMatch, new)
483 -- if both are partial matches generate a multiple match
484 , (partial2, LookupResult MultipleMatch lkp)
485 ] where new = compareNameComponent cstr lkp
486 partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]
487
488 -- | Find the canonical name for a lookup string in a list of names.
489 lookupName :: [String] -- ^ List of keys
490 -> String -- ^ Lookup string
491 -> LookupResult -- ^ Result of the lookup
492 lookupName l s = foldr (chooseLookupResult s)
493 (LookupResult FailMatch s) l
494
495 -- | Wrapper for a Haskell 'Set'
496 --
497 -- This type wraps a 'Set' and it is used in the Haskell to Python
498 -- opcode generation to transform a Haskell 'Set' into a Python 'list'
499 -- without duplicate elements.
500 newtype ListSet a = ListSet { unListSet :: Set a }
501 deriving (Eq, Show, Ord)
502
503 instance (Ord a, JSON a) => JSON (ListSet a) where
504 showJSON = JSON.showJSON . unListSet
505 readJSON = liftM ListSet . JSON.readJSON
506
507 emptyListSet :: ListSet a
508 emptyListSet = ListSet Set.empty
509
510 #if MIN_VERSION_base(4,6,0)
511 -- Down already defined in Data.Ord
512 #else
513 -- Copyright : (c) The University of Glasgow 2005
514 -- License : BSD-style
515
516 newtype Down a = Down a deriving (Eq, Show, Read)
517
518 instance Ord a => Ord (Down a) where
519 compare (Down x) (Down y) = y `compare` x
520
521 {- License text of the above code fragment:
522
523 The Glasgow Haskell Compiler License
524
525 Copyright 2004, The University Court of the University of Glasgow.
526 All rights reserved.
527
528 Redistribution and use in source and binary forms, with or without
529 modification, are permitted provided that the following conditions are met:
530
531 - Redistributions of source code must retain the above copyright notice,
532 this list of conditions and the following disclaimer.
533
534 - Redistributions in binary form must reproduce the above copyright notice,
535 this list of conditions and the following disclaimer in the documentation
536 and/or other materials provided with the distribution.
537
538 - Neither name of the University nor the names of its contributors may be
539 used to endorse or promote products derived from this software without
540 specific prior written permission.
541
542 THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
543 GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
544 INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
545 FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
546 UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
547 FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
548 DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
549 SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
550 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
551 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
552 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
553 DAMAGE.
554
555 -}
556
557 #endif