src/Ganeti/BasicTypes.hs

{-# LANGUAGE FlexibleInstances #-}

{-

Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

1. Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.

2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-}

module Ganeti.BasicTypes
  ( GenericResult(..)
  , genericResult
  , Result
  , ResultT(..)
  , resultT
  , FromString(..)
  , isOk
  , isBad
  , eitherToResult
  , annotateResult
  , iterateOk
  , select
  , runListHead
  , LookupResult(..)
  , MatchPriority(..)
  , lookupName
  , goodLookupResult
  , goodMatchPriority
  , prefixMatch
  , compareNameComponent
  , ListSet(..)
  , emptyListSet
  ) where

import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Data.Function
import Data.List
import Data.Maybe (listToMaybe)
import Data.Set (Set)
import qualified Data.Set as Set (empty)
import Text.JSON (JSON)
import qualified Text.JSON as JSON (readJSON, showJSON)

-- | Generic monad for our error handling mechanisms.
data GenericResult a b
  = Bad a
  | Ok b
    deriving (Show, Eq)

-- | Sum type structure of GenericResult.
genericResult :: (a -> c) -> (b -> c) -> GenericResult a b -> c
genericResult f _ (Bad a) = f a
genericResult _ g (Ok b) = g b

-- | Type alias for a string Result.
type Result = GenericResult String

-- | Type class for things that can be built from strings.
class FromString a where
  mkFromString :: String -> a

-- | Trivial 'String' instance; requires FlexibleInstances extension
-- though.
instance FromString [Char] where
  mkFromString = id

-- | 'Monad' instance for 'GenericResult'.
instance (FromString a) => Monad (GenericResult a) where
  (>>=) (Bad x) _ = Bad x
  (>>=) (Ok x) fn = fn x
  return = Ok
  fail   = Bad . mkFromString

instance Functor (GenericResult a) where
  fmap _ (Bad msg) = Bad msg
  fmap fn (Ok val) = Ok (fn val)

instance MonadPlus (GenericResult String) where
  mzero = Bad "zero Result when used as MonadPlus"
  -- for mplus, when we 'add' two Bad values, we concatenate their
  -- error descriptions
  (Bad x) `mplus` (Bad y) = Bad (x ++ "; " ++ y)
  (Bad _) `mplus` x = x
  x@(Ok _) `mplus` _ = x

instance Applicative (GenericResult a) where
  pure = Ok
  (Bad f) <*> _       = Bad f
  _       <*> (Bad x) = Bad x
  (Ok f)  <*> (Ok x)  = Ok $ f x

-- | This is a monad transformation for Result. It's implementation is
-- based on the implementations of MaybeT and ErrorT.
newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)}

instance (Monad m, FromString a) => Monad (ResultT a m) where
  fail err = ResultT (return . Bad $ mkFromString err)
  return   = lift . return
  x >>= f  = ResultT $ do
               a <- runResultT x
               case a of
                 Ok val -> runResultT $ f val
                 Bad err -> return $ Bad err

instance MonadTrans (ResultT a) where
  lift x = ResultT (liftM Ok x)

instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where
  liftIO = lift . liftIO

-- | Lift a `Result` value to a `ResultT`.
resultT :: Monad m => GenericResult a b -> ResultT a m b
resultT = ResultT . return

-- | Simple checker for whether a 'GenericResult' is OK.
isOk :: GenericResult a b -> Bool
isOk (Ok _) = True
isOk _      = False

-- | Simple checker for whether a 'GenericResult' is a failure.
isBad :: GenericResult a b -> Bool
isBad = not . isOk

-- | Converter from Either to 'GenericResult'.
eitherToResult :: Either a b -> GenericResult a b
eitherToResult (Left  s) = Bad s
eitherToResult (Right v) = Ok  v

-- | Annotate a Result with an ownership information.
annotateResult :: String -> Result a -> Result a
annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
annotateResult _ v = v

-- | Iterate while Ok.
iterateOk :: (a -> GenericResult b a) -> a -> [a]
iterateOk f a = genericResult (const []) ((:) a . iterateOk f) (f a)

-- * Misc functionality

-- | Return the first result with a True condition, or the default otherwise.
select :: a            -- ^ default result
       -> [(Bool, a)]  -- ^ list of \"condition, result\"
       -> a            -- ^ first result which has a True condition, or default
select def = maybe def snd . find fst

-- | Apply a function to the first element of a list, return the default
-- value, if the list is empty. This is just a convenient combination of
-- maybe and listToMaybe.
runListHead :: a -> (b -> a) -> [b] -> a
runListHead a f = maybe a f . listToMaybe

-- * Lookup of partial names functionality

-- | The priority of a match in a lookup result.
data MatchPriority = ExactMatch
                   | MultipleMatch
                   | PartialMatch
                   | FailMatch
                   deriving (Show, Enum, Eq, Ord)

-- | The result of a name lookup in a list.
data LookupResult = LookupResult
  { lrMatchPriority :: MatchPriority -- ^ The result type
  -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
  , lrContent :: String
  } deriving (Show)

-- | Lookup results have an absolute preference ordering.
instance Eq LookupResult where
  (==) = (==) `on` lrMatchPriority

instance Ord LookupResult where
  compare = compare `on` lrMatchPriority

-- | Check for prefix matches in names.
-- Implemented in Ganeti core utils.text.MatchNameComponent
-- as the regexp r"^%s(\..*)?$" % re.escape(key)
prefixMatch :: String  -- ^ Lookup
            -> String  -- ^ Full name
            -> Bool    -- ^ Whether there is a prefix match
prefixMatch = isPrefixOf . (++ ".")

-- | Is the lookup priority a "good" one?
goodMatchPriority :: MatchPriority -> Bool
goodMatchPriority ExactMatch = True
goodMatchPriority PartialMatch = True
goodMatchPriority _ = False

-- | Is the lookup result an actual match?
goodLookupResult :: LookupResult -> Bool
goodLookupResult = goodMatchPriority . lrMatchPriority

-- | Compares a canonical name and a lookup string.
compareNameComponent :: String        -- ^ Canonical (target) name
                     -> String        -- ^ Partial (lookup) name
                     -> LookupResult  -- ^ Result of the lookup
compareNameComponent cnl lkp =
  select (LookupResult FailMatch lkp)
  [ (cnl == lkp          , LookupResult ExactMatch cnl)
  , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)
  ]

-- | Lookup a string and choose the best result.
chooseLookupResult :: String       -- ^ Lookup key
                   -> String       -- ^ String to compare to the lookup key
                   -> LookupResult -- ^ Previous result
                   -> LookupResult -- ^ New result
chooseLookupResult lkp cstr old =
  -- default: use class order to pick the minimum result
  select (min new old)
  -- special cases:
  -- short circuit if the new result is an exact match
  [ (lrMatchPriority new == ExactMatch, new)
  -- if both are partial matches generate a multiple match
  , (partial2, LookupResult MultipleMatch lkp)
  ] where new = compareNameComponent cstr lkp
          partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]

-- | Find the canonical name for a lookup string in a list of names.
lookupName :: [String]      -- ^ List of keys
           -> String        -- ^ Lookup string
           -> LookupResult  -- ^ Result of the lookup
lookupName l s = foldr (chooseLookupResult s)
                       (LookupResult FailMatch s) l

-- | Wrapper for a Haskell 'Set'
--
-- This type wraps a 'Set' and it is used in the Haskell to Python
-- opcode generation to transform a Haskell 'Set' into a Python 'list'
-- without duplicate elements.
newtype ListSet a = ListSet { unListSet :: Set a }
  deriving (Eq, Show)

instance (Ord a, JSON a) => JSON (ListSet a) where
  showJSON = JSON.showJSON . unListSet
  readJSON = liftM ListSet . JSON.readJSON

emptyListSet :: ListSet a
emptyListSet = ListSet Set.empty