diff --git a/htools/Ganeti/HTools/Compat.hs b/htools/Ganeti/HTools/Compat.hs
index 36a0fbfce5c897add063188621d96217c6360a67..3f1cebbda2f5ddd2bcdc2056fabb19450fea65a5 100644
--- a/htools/Ganeti/HTools/Compat.hs
+++ b/htools/Ganeti/HTools/Compat.hs
@@ -2,7 +2,8 @@
{- | Compatibility helper module.
-This module holds definitions that help with supporting multiple library versions or transitions between versions.
+This module holds definitions that help with supporting multiple
+library versions or transitions between versions.
-}
@@ -28,9 +29,9 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.HTools.Compat
- ( rwhnf
- , Control.Parallel.Strategies.parMap
- ) where
+ ( rwhnf
+ , Control.Parallel.Strategies.parMap
+ ) where
import qualified Control.Parallel.Strategies
diff --git a/htools/Ganeti/HTools/Container.hs b/htools/Ganeti/HTools/Container.hs
index 5b2d3cc9de60a1a5325da078f2d404e51502cefb..ec8a11c80a76d8ebaaf2f630a4106c38c4ef4d5c 100644
--- a/htools/Ganeti/HTools/Container.hs
+++ b/htools/Ganeti/HTools/Container.hs
@@ -27,33 +27,32 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.HTools.Container
- (
- -- * Types
- Container
- , Key
- -- * Creation
- , IntMap.empty
- , IntMap.singleton
- , IntMap.fromList
- -- * Query
- , IntMap.size
- , IntMap.null
- , find
- , IntMap.findMax
- , IntMap.member
- -- * Update
- , add
- , addTwo
- , IntMap.map
- , IntMap.mapAccum
- , IntMap.filter
- -- * Conversion
- , IntMap.elems
- , IntMap.keys
- -- * Element functions
- , nameOf
- , findByName
- ) where
+ ( -- * Types
+ Container
+ , Key
+ -- * Creation
+ , IntMap.empty
+ , IntMap.singleton
+ , IntMap.fromList
+ -- * Query
+ , IntMap.size
+ , IntMap.null
+ , find
+ , IntMap.findMax
+ , IntMap.member
+ -- * Update
+ , add
+ , addTwo
+ , IntMap.map
+ , IntMap.mapAccum
+ , IntMap.filter
+ -- * Conversion
+ , IntMap.elems
+ , IntMap.keys
+ -- * Element functions
+ , nameOf
+ , findByName
+ ) where
import qualified Data.IntMap as IntMap
@@ -86,8 +85,8 @@ nameOf c k = T.nameOf $ find k c
findByName :: (T.Element a, Monad m) =>
Container a -> String -> m a
findByName c n =
- let all_elems = IntMap.elems c
- result = filter ((n `elem`) . T.allNames) all_elems
- in case result of
- [item] -> return item
- _ -> fail $ "Wrong number of elems found with name " ++ n
+ let all_elems = IntMap.elems c
+ result = filter ((n `elem`) . T.allNames) all_elems
+ in case result of
+ [item] -> return item
+ _ -> fail $ "Wrong number of elems found with name " ++ n
diff --git a/htools/Ganeti/HTools/ExtLoader.hs b/htools/Ganeti/HTools/ExtLoader.hs
index 0b63a2c18afc49b26ff36e8da97be767c185927e..669ef56e2f2ebccb1c98728514721cb1a4c8c9ee 100644
--- a/htools/Ganeti/HTools/ExtLoader.hs
+++ b/htools/Ganeti/HTools/ExtLoader.hs
@@ -28,10 +28,10 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.HTools.ExtLoader
- ( loadExternalData
- , commonSuffix
- , maybeSaveData
- ) where
+ ( loadExternalData
+ , commonSuffix
+ , maybeSaveData
+ ) where
import Control.Monad
import Data.Maybe (isJust, fromJust)
@@ -58,17 +58,17 @@ wrapIO = flip catch (return . Bad . show)
-- | Parses a user-supplied utilisation string.
parseUtilisation :: String -> Result (String, DynUtil)
parseUtilisation line =
- case sepSplit ' ' line of
- [name, cpu, mem, dsk, net] ->
- do
- rcpu <- tryRead name cpu
- rmem <- tryRead name mem
- rdsk <- tryRead name dsk
- rnet <- tryRead name net
- let du = DynUtil { cpuWeight = rcpu, memWeight = rmem
- , dskWeight = rdsk, netWeight = rnet }
- return (name, du)
- _ -> Bad $ "Cannot parse line " ++ line
+ case sepSplit ' ' line of
+ [name, cpu, mem, dsk, net] ->
+ do
+ rcpu <- tryRead name cpu
+ rmem <- tryRead name mem
+ rdsk <- tryRead name dsk
+ rnet <- tryRead name net
+ let du = DynUtil { cpuWeight = rcpu, memWeight = rmem
+ , dskWeight = rdsk, netWeight = rnet }
+ return (name, du)
+ _ -> Bad $ "Cannot parse line " ++ line
-- | External tool data loader from a variety of sources.
loadExternalData :: Options
@@ -100,28 +100,28 @@ loadExternalData opts = do
Nothing -> return "")
let util_data = mapM parseUtilisation $ lines util_contents
util_data' <- (case util_data of
- Ok x -> return x
+ Ok x -> return x
Bad y -> do
hPutStrLn stderr ("Error: can't parse utilisation" ++
" data: " ++ show y)
exitWith $ ExitFailure 1)
input_data <-
- case () of
- _ | setRapi -> wrapIO $ Rapi.loadData mhost
- | setLuxi -> wrapIO $ Luxi.loadData $ fromJust lsock
- | setSim -> Simu.loadData simdata
- | setFile -> wrapIO $ Text.loadData $ fromJust tfile
- | otherwise -> return $ Bad "No backend selected! Exiting."
+ case () of
+ _ | setRapi -> wrapIO $ Rapi.loadData mhost
+ | setLuxi -> wrapIO $ Luxi.loadData $ fromJust lsock
+ | setSim -> Simu.loadData simdata
+ | setFile -> wrapIO $ Text.loadData $ fromJust tfile
+ | otherwise -> return $ Bad "No backend selected! Exiting."
let ldresult = input_data >>= mergeData util_data' exTags selInsts exInsts
cdata <-
- (case ldresult of
- Ok x -> return x
- Bad s -> do
- hPrintf stderr
- "Error: failed to load data, aborting. Details:\n%s\n" s:: IO ()
- exitWith $ ExitFailure 1
- )
+ (case ldresult of
+ Ok x -> return x
+ Bad s -> do
+ hPrintf stderr
+ "Error: failed to load data, aborting. Details:\n%s\n" s:: IO ()
+ exitWith $ ExitFailure 1
+ )
let (fix_msgs, nl) = checkData (cdNodes cdata) (cdInstances cdata)
unless (optVerbose opts == 0) $ maybeShowWarnings fix_msgs
diff --git a/htools/Ganeti/HTools/Group.hs b/htools/Ganeti/HTools/Group.hs
index 6df5f4c74223863ba710fecd3b0dc68f0c76c1ac..3206236a01420aa60d3a3ff160339869ba3ba657 100644
--- a/htools/Ganeti/HTools/Group.hs
+++ b/htools/Ganeti/HTools/Group.hs
@@ -24,14 +24,14 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.HTools.Group
- ( Group(..)
- , List
- , AssocList
- -- * Constructor
- , create
- , setIdx
- , isAllocable
- ) where
+ ( Group(..)
+ , List
+ , AssocList
+ -- * Constructor
+ , create
+ , setIdx
+ , isAllocable
+ ) where
import qualified Ganeti.HTools.Container as Container
@@ -41,20 +41,20 @@ import qualified Ganeti.HTools.Types as T
-- | The node group type.
data Group = Group
- { name :: String -- ^ The node name
- , uuid :: T.GroupID -- ^ The UUID of the group
- , idx :: T.Gdx -- ^ Internal index for book-keeping
- , allocPolicy :: T.AllocPolicy -- ^ The allocation policy for this group
- } deriving (Show, Read, Eq)
+ { name :: String -- ^ The node name
+ , uuid :: T.GroupID -- ^ The UUID of the group
+ , idx :: T.Gdx -- ^ Internal index for book-keeping
+ , allocPolicy :: T.AllocPolicy -- ^ The allocation policy for this group
+ } deriving (Show, Read, Eq)
-- Note: we use the name as the alias, and the UUID as the official
-- name
instance T.Element Group where
- nameOf = uuid
- idxOf = idx
- setAlias = setName
- setIdx = setIdx
- allNames n = [name n, uuid n]
+ nameOf = uuid
+ idxOf = idx
+ setAlias = setName
+ setIdx = setIdx
+ allNames n = [name n, uuid n]
-- | A simple name for the int, node association list.
type AssocList = [(T.Gdx, Group)]
@@ -67,11 +67,11 @@ type List = Container.Container Group
-- | Create a new group.
create :: String -> T.GroupID -> T.AllocPolicy -> Group
create name_init id_init apol_init =
- Group { name = name_init
- , uuid = id_init
- , allocPolicy = apol_init
- , idx = -1
- }
+ Group { name = name_init
+ , uuid = id_init
+ , allocPolicy = apol_init
+ , idx = -1
+ }
-- | Sets the group index.
--
diff --git a/htools/Ganeti/HTools/Instance.hs b/htools/Ganeti/HTools/Instance.hs
index 22d3c96592359bdf2896856c0c0e4282b9038770..5a2b7e252cbed18a20b99198ea9431826cf50850 100644
--- a/htools/Ganeti/HTools/Instance.hs
+++ b/htools/Ganeti/HTools/Instance.hs
@@ -27,29 +27,29 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.HTools.Instance
- ( Instance(..)
- , AssocList
- , List
- , create
- , instanceRunning
- , instanceOffline
- , instanceDown
- , applyIfOnline
- , setIdx
- , setName
- , setAlias
- , setPri
- , setSec
- , setBoth
- , setMovable
- , specOf
- , shrinkByType
- , localStorageTemplates
- , hasSecondary
- , requiredNodes
- , allNodes
- , usesLocalStorage
- ) where
+ ( Instance(..)
+ , AssocList
+ , List
+ , create
+ , instanceRunning
+ , instanceOffline
+ , instanceDown
+ , applyIfOnline
+ , setIdx
+ , setName
+ , setAlias
+ , setPri
+ , setSec
+ , setBoth
+ , setMovable
+ , specOf
+ , shrinkByType
+ , localStorageTemplates
+ , hasSecondary
+ , requiredNodes
+ , allNodes
+ , usesLocalStorage
+ ) where
import qualified Ganeti.HTools.Types as T
import qualified Ganeti.HTools.Container as Container
@@ -61,39 +61,39 @@ import Ganeti.HTools.Utils
-- | The instance type.
data Instance = Instance
- { name :: String -- ^ The instance name
- , alias :: String -- ^ The shortened name
- , mem :: Int -- ^ Memory of the instance
- , dsk :: Int -- ^ Disk size of instance
- , vcpus :: Int -- ^ Number of VCPUs
- , runSt :: T.InstanceStatus -- ^ Original run status
- , pNode :: T.Ndx -- ^ Original primary node
- , sNode :: T.Ndx -- ^ Original secondary node
- , idx :: T.Idx -- ^ Internal index
- , util :: T.DynUtil -- ^ Dynamic resource usage
- , movable :: Bool -- ^ Can and should the instance be moved?
- , autoBalance :: Bool -- ^ Is the instance auto-balanced?
- , tags :: [String] -- ^ List of instance tags
- , diskTemplate :: T.DiskTemplate -- ^ The disk template of the instance
- } deriving (Show, Read)
+ { name :: String -- ^ The instance name
+ , alias :: String -- ^ The shortened name
+ , mem :: Int -- ^ Memory of the instance
+ , dsk :: Int -- ^ Disk size of instance
+ , vcpus :: Int -- ^ Number of VCPUs
+ , runSt :: T.InstanceStatus -- ^ Original run status
+ , pNode :: T.Ndx -- ^ Original primary node
+ , sNode :: T.Ndx -- ^ Original secondary node
+ , idx :: T.Idx -- ^ Internal index
+ , util :: T.DynUtil -- ^ Dynamic resource usage
+ , movable :: Bool -- ^ Can and should the instance be moved?
+ , autoBalance :: Bool -- ^ Is the instance auto-balanced?
+ , tags :: [String] -- ^ List of instance tags
+ , diskTemplate :: T.DiskTemplate -- ^ The disk template of the instance
+ } deriving (Show, Read)
instance T.Element Instance where
- nameOf = name
- idxOf = idx
- setAlias = setAlias
- setIdx = setIdx
- allNames n = [name n, alias n]
+ nameOf = name
+ idxOf = idx
+ setAlias = setAlias
+ setIdx = setIdx
+ allNames n = [name n, alias n]
-- | Check if instance is running.
instanceRunning :: Instance -> Bool
instanceRunning (Instance {runSt = T.Running}) = True
instanceRunning (Instance {runSt = T.ErrorUp}) = True
-instanceRunning _ = False
+instanceRunning _ = False
-- | Check if instance is offline.
instanceOffline :: Instance -> Bool
instanceOffline (Instance {runSt = T.AdminOffline}) = True
-instanceOffline _ = False
+instanceOffline _ = False
-- | Check if instance is down.
instanceDown :: Instance -> Bool
@@ -141,21 +141,21 @@ create :: String -> Int -> Int -> Int -> T.InstanceStatus
-> [String] -> Bool -> T.Ndx -> T.Ndx -> T.DiskTemplate -> Instance
create name_init mem_init dsk_init vcpus_init run_init tags_init
auto_balance_init pn sn dt =
- Instance { name = name_init
- , alias = name_init
- , mem = mem_init
- , dsk = dsk_init
- , vcpus = vcpus_init
- , runSt = run_init
- , pNode = pn
- , sNode = sn
- , idx = -1
- , util = T.baseUtil
- , tags = tags_init
- , movable = supportsMoves dt
- , autoBalance = auto_balance_init
- , diskTemplate = dt
- }
+ Instance { name = name_init
+ , alias = name_init
+ , mem = mem_init
+ , dsk = dsk_init
+ , vcpus = vcpus_init
+ , runSt = run_init
+ , pNode = pn
+ , sNode = sn
+ , idx = -1
+ , util = T.baseUtil
+ , tags = tags_init
+ , movable = supportsMoves dt
+ , autoBalance = auto_balance_init
+ , diskTemplate = dt
+ }
-- | Changes the index.
--
@@ -228,7 +228,7 @@ shrinkByType _ f = T.Bad $ "Unhandled failure mode " ++ show f
-- | Return the spec of an instance.
specOf :: Instance -> T.RSpec
specOf Instance { mem = m, dsk = d, vcpus = c } =
- T.RSpec { T.rspecCpu = c, T.rspecMem = m, T.rspecDsk = d }
+ T.RSpec { T.rspecCpu = c, T.rspecMem = m, T.rspecDsk = d }
-- | Checks whether the instance uses a secondary node.
--
diff --git a/htools/Ganeti/HTools/JSON.hs b/htools/Ganeti/HTools/JSON.hs
index c20210ec34c70d6cea5f288d8dac676e312aae63..6fe45bafc28546a11a9a14262c5cf0404a46da85 100644
--- a/htools/Ganeti/HTools/JSON.hs
+++ b/htools/Ganeti/HTools/JSON.hs
@@ -22,18 +22,18 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.HTools.JSON
- ( fromJResult
- , readEitherString
- , JSRecord
- , loadJSArray
- , fromObj
- , maybeFromObj
- , fromObjWithDefault
- , fromJVal
- , asJSObject
- , asObjectList
- )
- where
+ ( fromJResult
+ , readEitherString
+ , JSRecord
+ , loadJSArray
+ , fromObj
+ , maybeFromObj
+ , fromObjWithDefault
+ , fromJVal
+ , asJSObject
+ , asObjectList
+ )
+ where
import Control.Monad (liftM)
import Data.Maybe (fromMaybe)
@@ -57,9 +57,9 @@ fromJResult _ (J.Ok x) = return x
-- context of the current monad.
readEitherString :: (Monad m) => J.JSValue -> m String
readEitherString v =
- case v of
- J.JSString s -> return $ J.fromJSString s
- _ -> fail "Wrong JSON type"
+ case v of
+ J.JSString s -> return $ J.fromJSString s
+ _ -> fail "Wrong JSON type"
-- | Converts a JSON message into an array of JSON objects.
loadJSArray :: (Monad m)
@@ -71,18 +71,18 @@ loadJSArray s = fromJResult s . J.decodeStrict
-- | Reads the value of a key in a JSON object.
fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
fromObj o k =
- case lookup k o of
- Nothing -> fail $ printf "key '%s' not found, object contains only %s"
- k (show (map fst o))
- Just val -> fromKeyValue k val
+ case lookup k o of
+ Nothing -> fail $ printf "key '%s' not found, object contains only %s"
+ k (show (map fst o))
+ Just val -> fromKeyValue k val
-- | Reads the value of an optional key in a JSON object.
maybeFromObj :: (J.JSON a, Monad m) =>
JSRecord -> String -> m (Maybe a)
maybeFromObj o k =
- case lookup k o of
- Nothing -> return Nothing
- Just val -> liftM Just (fromKeyValue k val)
+ case lookup k o of
+ Nothing -> return Nothing
+ Just val -> liftM Just (fromKeyValue k val)
-- | Reads the value of a key in a JSON object with a default if missing.
fromObjWithDefault :: (J.JSON a, Monad m) =>
@@ -100,10 +100,10 @@ fromKeyValue k val =
-- | Small wrapper over readJSON.
fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
fromJVal v =
- case J.readJSON v of
- J.Error s -> fail ("Cannot convert value '" ++ show v ++
- "', error: " ++ s)
- J.Ok x -> return x
+ case J.readJSON v of
+ J.Error s -> fail ("Cannot convert value '" ++ show v ++
+ "', error: " ++ s)
+ J.Ok x -> return x
-- | Converts a JSON value into a JSON object.
asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
diff --git a/htools/Ganeti/HTools/Loader.hs b/htools/Ganeti/HTools/Loader.hs
index 0e5f10a83c5b35a8d313988b021126b8d0ea037e..ff85ef87c6df25d2125b57a1e08d8e61252297e8 100644
--- a/htools/Ganeti/HTools/Loader.hs
+++ b/htools/Ganeti/HTools/Loader.hs
@@ -27,24 +27,24 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.HTools.Loader
- ( mergeData
- , checkData
- , assignIndices
- , lookupName
- , goodLookupResult
- , lookupNode
- , lookupInstance
- , lookupGroup
- , commonSuffix
- , RqType(..)
- , Request(..)
- , ClusterData(..)
- , emptyCluster
- , compareNameComponent
- , prefixMatch
- , LookupResult(..)
- , MatchPriority(..)
- ) where
+ ( mergeData
+ , checkData
+ , assignIndices
+ , lookupName
+ , goodLookupResult
+ , lookupNode
+ , lookupInstance
+ , lookupGroup
+ , commonSuffix
+ , RqType(..)
+ , Request(..)
+ , ClusterData(..)
+ , emptyCluster
+ , compareNameComponent
+ , prefixMatch
+ , LookupResult(..)
+ , MatchPriority(..)
+ ) where
import Data.List
import Data.Function
@@ -74,23 +74,23 @@ request-specific fields.
-}
data RqType
- = Allocate Instance.Instance Int -- ^ A new instance allocation
- | Relocate Idx Int [Ndx] -- ^ Choose a new secondary node
- | NodeEvacuate [Idx] EvacMode -- ^ node-evacuate mode
- | ChangeGroup [Gdx] [Idx] -- ^ Multi-relocate mode
+ = Allocate Instance.Instance Int -- ^ A new instance allocation
+ | Relocate Idx Int [Ndx] -- ^ Choose a new secondary node
+ | NodeEvacuate [Idx] EvacMode -- ^ node-evacuate mode
+ | ChangeGroup [Gdx] [Idx] -- ^ Multi-relocate mode
deriving (Show, Read)
-- | A complete request, as received from Ganeti.
data Request = Request RqType ClusterData
- deriving (Show, Read)
+ deriving (Show, Read)
-- | The cluster state.
data ClusterData = ClusterData
- { cdGroups :: Group.List -- ^ The node group list
- , cdNodes :: Node.List -- ^ The node list
- , cdInstances :: Instance.List -- ^ The instance list
- , cdTags :: [String] -- ^ The cluster tags
- } deriving (Show, Read)
+ { cdGroups :: Group.List -- ^ The node group list
+ , cdNodes :: Node.List -- ^ The node list
+ , cdInstances :: Instance.List -- ^ The instance list
+ , cdTags :: [String] -- ^ The cluster tags
+ } deriving (Show, Read)
-- | The priority of a match in a lookup result.
data MatchPriority = ExactMatch
@@ -101,10 +101,10 @@ data MatchPriority = ExactMatch
-- | 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, Read)
+ { lrMatchPriority :: MatchPriority -- ^ The result type
+ -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
+ , lrContent :: String
+ } deriving (Show, Read)
-- | Lookup results have an absolute preference ordering.
instance Eq LookupResult where
@@ -122,23 +122,23 @@ emptyCluster = ClusterData Container.empty Container.empty Container.empty []
-- | Lookups a node into an assoc list.
lookupNode :: (Monad m) => NameAssoc -> String -> String -> m Ndx
lookupNode ktn inst node =
- case M.lookup node ktn of
- Nothing -> fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst
- Just idx -> return idx
+ case M.lookup node ktn of
+ Nothing -> fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst
+ Just idx -> return idx
-- | Lookups an instance into an assoc list.
lookupInstance :: (Monad m) => NameAssoc -> String -> m Idx
lookupInstance kti inst =
- case M.lookup inst kti of
- Nothing -> fail $ "Unknown instance '" ++ inst ++ "'"
- Just idx -> return idx
+ case M.lookup inst kti of
+ Nothing -> fail $ "Unknown instance '" ++ inst ++ "'"
+ Just idx -> return idx
-- | Lookups a group into an assoc list.
lookupGroup :: (Monad m) => NameAssoc -> String -> String -> m Gdx
lookupGroup ktg nname gname =
- case M.lookup gname ktg of
- Nothing -> fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname
- Just idx -> return idx
+ case M.lookup gname ktg of
+ Nothing -> fail $ "Unknown group '" ++ gname ++ "' for node " ++ nname
+ Just idx -> return idx
-- | Check for prefix matches in names.
-- Implemented in Ganeti core utils.text.MatchNameComponent
@@ -206,26 +206,23 @@ fixNodes :: Node.List
-> Instance.Instance
-> Node.List
fixNodes accu inst =
- let
- pdx = Instance.pNode inst
- sdx = Instance.sNode inst
- pold = Container.find pdx accu
- pnew = Node.setPri pold inst
- ac2 = Container.add pdx pnew accu
- in
- if sdx /= Node.noSecondary
- then let sold = Container.find sdx accu
- snew = Node.setSec sold inst
- in Container.add sdx snew ac2
- else ac2
+ let pdx = Instance.pNode inst
+ sdx = Instance.sNode inst
+ pold = Container.find pdx accu
+ pnew = Node.setPri pold inst
+ ac2 = Container.add pdx pnew accu
+ in if sdx /= Node.noSecondary
+ then let sold = Container.find sdx accu
+ snew = Node.setSec sold inst
+ in Container.add sdx snew ac2
+ else ac2
-- | Remove non-selected tags from the exclusion list.
filterExTags :: [String] -> Instance.Instance -> Instance.Instance
filterExTags tl inst =
- let old_tags = Instance.tags inst
- new_tags = filter (\tag -> any (`isPrefixOf` tag) tl)
- old_tags
- in inst { Instance.tags = new_tags }
+ let old_tags = Instance.tags inst
+ new_tags = filter (\tag -> any (`isPrefixOf` tag) tl) old_tags
+ in inst { Instance.tags = new_tags }
-- | Update the movable attribute.
updateMovable :: [String] -- ^ Selected instances (if not empty)
@@ -233,9 +230,9 @@ updateMovable :: [String] -- ^ Selected instances (if not empty)
-> Instance.Instance -- ^ Target Instance
-> Instance.Instance -- ^ Target Instance with updated attribute
updateMovable selinsts exinsts inst =
- if Instance.sNode inst == Node.noSecondary ||
- Instance.name inst `elem` exinsts ||
- not (null selinsts || Instance.name inst `elem` selinsts)
+ if Instance.sNode inst == Node.noSecondary ||
+ Instance.name inst `elem` exinsts ||
+ not (null selinsts || Instance.name inst `elem` selinsts)
then Instance.setMovable inst False
else inst
@@ -244,23 +241,23 @@ updateMovable selinsts exinsts inst =
longestDomain :: [String] -> String
longestDomain [] = ""
longestDomain (x:xs) =
- foldr (\ suffix accu -> if all (isSuffixOf suffix) xs
- then suffix
- else accu)
- "" $ filter (isPrefixOf ".") (tails x)
+ foldr (\ suffix accu -> if all (isSuffixOf suffix) xs
+ then suffix
+ else accu)
+ "" $ filter (isPrefixOf ".") (tails x)
-- | Extracts the exclusion tags from the cluster configuration.
extractExTags :: [String] -> [String]
extractExTags =
- map (drop (length exTagsPrefix)) .
- filter (isPrefixOf exTagsPrefix)
+ map (drop (length exTagsPrefix)) .
+ filter (isPrefixOf exTagsPrefix)
-- | Extracts the common suffix from node\/instance names.
commonSuffix :: Node.List -> Instance.List -> String
commonSuffix nl il =
- let node_names = map Node.name $ Container.elems nl
- inst_names = map Instance.name $ Container.elems il
- in longestDomain (node_names ++ inst_names)
+ let node_names = map Node.name $ Container.elems nl
+ inst_names = map Instance.name $ Container.elems il
+ in longestDomain (node_names ++ inst_names)
-- | Initializer function that loads the data from a node and instance
-- list and massages it into the correct format.
@@ -328,16 +325,16 @@ checkData nl il =
-- | Compute the amount of memory used by primary instances on a node.
nodeImem :: Node.Node -> Instance.List -> Int
nodeImem node il =
- let rfind = flip Container.find il
- il' = map rfind $ Node.pList node
- oil' = filter (not . Instance.instanceOffline) il'
- in sum . map Instance.mem $ oil'
+ let rfind = flip Container.find il
+ il' = map rfind $ Node.pList node
+ oil' = filter (not . Instance.instanceOffline) il'
+ in sum . map Instance.mem $ oil'
-- | Compute the amount of disk used by instances on a node (either primary
-- or secondary).
nodeIdsk :: Node.Node -> Instance.List -> Int
nodeIdsk node il =
- let rfind = flip Container.find il
- in sum . map (Instance.dsk . rfind)
- $ Node.pList node ++ Node.sList node
+ let rfind = flip Container.find il
+ in sum . map (Instance.dsk . rfind)
+ $ Node.pList node ++ Node.sList node
diff --git a/htools/Ganeti/HTools/Luxi.hs b/htools/Ganeti/HTools/Luxi.hs
index 4baa98b3b9a0ffd831f559f7c34016cb3aeed9bd..b1f55c141ca758a03bfc80ad08ecbbd16321dc53 100644
--- a/htools/Ganeti/HTools/Luxi.hs
+++ b/htools/Ganeti/HTools/Luxi.hs
@@ -24,10 +24,9 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.HTools.Luxi
- (
- loadData
- , parseData
- ) where
+ ( loadData
+ , parseData
+ ) where
import qualified Control.Exception as E
import Text.JSON.Types
@@ -53,20 +52,20 @@ getData x = fail $ "Invalid input, expected dict entry but got " ++ show x
parseQueryField :: (Monad m) => JSValue -> m (JSValue, JSValue)
parseQueryField (JSArray [status, result]) = return (status, result)
parseQueryField o =
- fail $ "Invalid query field, expected (status, value) but got " ++ show o
+ fail $ "Invalid query field, expected (status, value) but got " ++ show o
-- | Parse a result row.
parseQueryRow :: (Monad m) => JSValue -> m [(JSValue, JSValue)]
parseQueryRow (JSArray arr) = mapM parseQueryField arr
parseQueryRow o =
- fail $ "Invalid query row result, expected array but got " ++ show o
+ fail $ "Invalid query row result, expected array but got " ++ show o
-- | Parse an overall query result and get the [(status, value)] list
-- for each element queried.
parseQueryResult :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
parseQueryResult (JSArray arr) = mapM parseQueryRow arr
parseQueryResult o =
- fail $ "Invalid query result, expected array but got " ++ show o
+ fail $ "Invalid query result, expected array but got " ++ show o
-- | Prepare resulting output as parsers expect it.
extractArray :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
@@ -76,8 +75,8 @@ extractArray v =
-- | Testing result status for more verbose error message.
fromJValWithStatus :: (Text.JSON.JSON a, Monad m) => (JSValue, JSValue) -> m a
fromJValWithStatus (st, v) = do
- st' <- fromJVal st
- L.checkRS st' v >>= fromJVal
+ st' <- fromJVal st
+ L.checkRS st' v >>= fromJVal
-- | Annotate errors when converting values with owner/attribute for
-- better debugging.
@@ -88,9 +87,9 @@ genericConvert :: (Text.JSON.JSON a) =>
-> (JSValue, JSValue) -- ^ The value we're trying to convert
-> Result a -- ^ The annotated result
genericConvert otype oname oattr =
- annotateResult (otype ++ " '" ++ oname ++
- "', error while reading attribute '" ++
- oattr ++ "'") . fromJValWithStatus
+ annotateResult (otype ++ " '" ++ oname ++
+ "', error while reading attribute '" ++
+ oattr ++ "'") . fromJValWithStatus
-- * Data querying functionality
@@ -104,9 +103,9 @@ queryNodesMsg =
-- | The input data for instance query.
queryInstancesMsg :: L.LuxiOp
queryInstancesMsg =
- L.Query L.QRInstance ["name", "disk_usage", "be/memory", "be/vcpus",
- "status", "pnode", "snodes", "tags", "oper_ram",
- "be/auto_balance", "disk_template"] ()
+ L.Query L.QRInstance ["name", "disk_usage", "be/memory", "be/vcpus",
+ "status", "pnode", "snodes", "tags", "oper_ram",
+ "be/auto_balance", "disk_template"] ()
-- | The input data for cluster query.
queryClusterInfoMsg :: L.LuxiOp
diff --git a/htools/Ganeti/HTools/PeerMap.hs b/htools/Ganeti/HTools/PeerMap.hs
index 2d17d2ace313dfbdfe11eca31982048d86a85bab..f17857899a2659442e84f12719893e6d2b697a50 100644
--- a/htools/Ganeti/HTools/PeerMap.hs
+++ b/htools/Ganeti/HTools/PeerMap.hs
@@ -8,7 +8,7 @@ implementation should be easy in case it's needed.
{-
-Copyright (C) 2009 Google Inc.
+Copyright (C) 2009, 2011 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -28,16 +28,16 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.HTools.PeerMap
- ( PeerMap
- , Key
- , Elem
- , empty
- , accumArray
- , Ganeti.HTools.PeerMap.find
- , add
- , remove
- , maxElem
- ) where
+ ( PeerMap
+ , Key
+ , Elem
+ , empty
+ , accumArray
+ , Ganeti.HTools.PeerMap.find
+ , add
+ , remove
+ , maxElem
+ ) where
import Data.Maybe (fromMaybe)
import Data.List
@@ -70,9 +70,9 @@ pmCompare a b = comparing snd b a
-- | Add or update (via a custom function) an element.
addWith :: (Elem -> Elem -> Elem) -> Key -> Elem -> PeerMap -> PeerMap
addWith fn k v lst =
- case lookup k lst of
- Nothing -> insertBy pmCompare (k, v) lst
- Just o -> insertBy pmCompare (k, fn o v) (remove k lst)
+ case lookup k lst of
+ Nothing -> insertBy pmCompare (k, v) lst
+ Just o -> insertBy pmCompare (k, fn o v) (remove k lst)
-- | Create a PeerMap from an association list, with possible duplicates.
accumArray :: (Elem -> Elem -> Elem) -- ^ function used to merge the elements
diff --git a/htools/Ganeti/HTools/Program/Hail.hs b/htools/Ganeti/HTools/Program/Hail.hs
index 1fb9b80d4edbd4cca8c8c024669d764a09a69b3d..77b6d1477e1e145046d9c99c7930816b53cecb82 100644
--- a/htools/Ganeti/HTools/Program/Hail.hs
+++ b/htools/Ganeti/HTools/Program/Hail.hs
@@ -39,14 +39,14 @@ import Ganeti.HTools.ExtLoader (maybeSaveData)
-- | Options list and functions.
options :: [OptType]
options =
- [ oPrintNodes
- , oSaveCluster
- , oDataFile
- , oNodeSim
- , oVerbose
- , oShowVer
- , oShowHelp
- ]
+ [ oPrintNodes
+ , oSaveCluster
+ , oDataFile
+ , oNodeSim
+ , oVerbose
+ , oShowVer
+ , oShowHelp
+ ]
-- | Main function.
main :: IO ()
diff --git a/htools/Ganeti/HTools/Program/Hscan.hs b/htools/Ganeti/HTools/Program/Hscan.hs
index 0dbcf6e08f3bdf6bf5870a7ef5cd0f13772b2b3e..62a51d8dd120186a26a02709480e4e7108813bf8 100644
--- a/htools/Ganeti/HTools/Program/Hscan.hs
+++ b/htools/Ganeti/HTools/Program/Hscan.hs
@@ -49,41 +49,36 @@ import Ganeti.HTools.Types
-- | Options list and functions.
options :: [OptType]
options =
- [ oPrintNodes
- , oOutputDir
- , oLuxiSocket
- , oVerbose
- , oNoHeaders
- , oShowVer
- , oShowHelp
- ]
+ [ oPrintNodes
+ , oOutputDir
+ , oLuxiSocket
+ , oVerbose
+ , oNoHeaders
+ , oShowVer
+ , oShowHelp
+ ]
-- | Return a one-line summary of cluster state.
printCluster :: Node.List -> Instance.List
-> String
printCluster nl il =
- let (bad_nodes, bad_instances) = Cluster.computeBadItems nl il
- ccv = Cluster.compCV nl
- nodes = Container.elems nl
- insts = Container.elems il
- t_ram = sum . map Node.tMem $ nodes
- t_dsk = sum . map Node.tDsk $ nodes
- f_ram = sum . map Node.fMem $ nodes
- f_dsk = sum . map Node.fDsk $ nodes
- in
- printf "%5d %5d %5d %5d %6.0f %6d %6.0f %6d %.8f"
- (length nodes) (length insts)
- (length bad_nodes) (length bad_instances)
- t_ram f_ram
- (t_dsk / 1024) (f_dsk `div` 1024)
- ccv
-
+ let (bad_nodes, bad_instances) = Cluster.computeBadItems nl il
+ ccv = Cluster.compCV nl
+ nodes = Container.elems nl
+ insts = Container.elems il
+ t_ram = sum . map Node.tMem $ nodes
+ t_dsk = sum . map Node.tDsk $ nodes
+ f_ram = sum . map Node.fMem $ nodes
+ f_dsk = sum . map Node.fDsk $ nodes
+ in printf "%5d %5d %5d %5d %6.0f %6d %6.0f %6d %.8f"
+ (length nodes) (length insts)
+ (length bad_nodes) (length bad_instances)
+ t_ram f_ram (t_dsk / 1024) (f_dsk `div` 1024) ccv
-- | Replace slashes with underscore for saving to filesystem.
fixSlash :: String -> String
fixSlash = map (\x -> if x == '/' then '_' else x)
-
-- | Generates serialized data from loader input.
processData :: ClusterData -> Result ClusterData
processData input_data = do
diff --git a/htools/Ganeti/HTools/QCHelper.hs b/htools/Ganeti/HTools/QCHelper.hs
index 79550ac5835bec55f67b1467cfef6b971eae2e52..8cd165a962339e3bae2864ec7761ada9aa023aa0 100644
--- a/htools/Ganeti/HTools/QCHelper.hs
+++ b/htools/Ganeti/HTools/QCHelper.hs
@@ -26,8 +26,8 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.HTools.QCHelper
- ( testSuite
- ) where
+ ( testSuite
+ ) where
import Test.QuickCheck
import Language.Haskell.TH
diff --git a/htools/Ganeti/HTools/Rapi.hs b/htools/Ganeti/HTools/Rapi.hs
index ce310edf68204082e8a383e13ce2aa53368447c5..c04d87c36ee32256cd487908cd64e919ef345c8d 100644
--- a/htools/Ganeti/HTools/Rapi.hs
+++ b/htools/Ganeti/HTools/Rapi.hs
@@ -26,10 +26,9 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
{-# LANGUAGE BangPatterns, CPP #-}
module Ganeti.HTools.Rapi
- (
- loadData
- , parseData
- ) where
+ ( loadData
+ , parseData
+ ) where
import Data.Maybe (fromMaybe)
#ifndef NO_CURL
@@ -76,7 +75,8 @@ getUrl url = do
-- | Append the default port if not passed in.
formatHost :: String -> String
formatHost master =
- if ':' `elem` master then master
+ if ':' `elem` master
+ then master
else "https://" ++ master ++ ":" ++ show C.defaultRapiPort
-- | Parse a instance list in JSON format.
@@ -84,18 +84,18 @@ getInstances :: NameAssoc
-> String
-> Result [(String, Instance.Instance)]
getInstances ktn body =
- loadJSArray "Parsing instance data" body >>=
- mapM (parseInstance ktn . fromJSObject)
+ loadJSArray "Parsing instance data" body >>=
+ mapM (parseInstance ktn . fromJSObject)
-- | Parse a node list in JSON format.
getNodes :: NameAssoc -> String -> Result [(String, Node.Node)]
getNodes ktg body = loadJSArray "Parsing node data" body >>=
- mapM (parseNode ktg . fromJSObject)
+ mapM (parseNode ktg . fromJSObject)
-- | Parse a group list in JSON format.
getGroups :: String -> Result [(String, Group.Group)]
getGroups body = loadJSArray "Parsing group data" body >>=
- mapM (parseGroup . fromJSObject)
+ mapM (parseGroup . fromJSObject)
-- | Construct an instance from a JSON object.
parseInstance :: NameAssoc
diff --git a/htools/Ganeti/HTools/Simu.hs b/htools/Ganeti/HTools/Simu.hs
index 01a56249a7830fe4549789161d59ed6bf169e2e2..dc488de9516a282d638674a962e1d1a5a3d1920d 100644
--- a/htools/Ganeti/HTools/Simu.hs
+++ b/htools/Ganeti/HTools/Simu.hs
@@ -26,10 +26,9 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.HTools.Simu
- (
- loadData
- , parseData
- ) where
+ ( loadData
+ , parseData
+ ) where
import Control.Monad (mplus)
import Text.Printf (printf)
@@ -52,18 +51,18 @@ apolAbbrev c | c == "p" = return AllocPreferred
-- | Parse the string description into nodes.
parseDesc :: String -> Result (AllocPolicy, Int, Int, Int, Int)
parseDesc desc =
- case sepSplit ',' desc of
- [a, n, d, m, c] -> do
- apol <- allocPolicyFromRaw a `mplus` apolAbbrev a
- ncount <- tryRead "node count" n
- disk <- annotateResult "disk size" (parseUnit d)
- mem <- annotateResult "memory size" (parseUnit m)
- cpu <- tryRead "cpu count" c
- return (apol, ncount, disk, mem, cpu)
- es -> fail $ printf
- "Invalid cluster specification, expected 5 comma-separated\
- \ sections (allocation policy, node count, disk size,\
- \ memory size, number of CPUs) but got %d: '%s'" (length es) desc
+ case sepSplit ',' desc of
+ [a, n, d, m, c] -> do
+ apol <- allocPolicyFromRaw a `mplus` apolAbbrev a
+ ncount <- tryRead "node count" n
+ disk <- annotateResult "disk size" (parseUnit d)
+ mem <- annotateResult "memory size" (parseUnit m)
+ cpu <- tryRead "cpu count" c
+ return (apol, ncount, disk, mem, cpu)
+ es -> fail $ printf
+ "Invalid cluster specification, expected 5 comma-separated\
+ \ sections (allocation policy, node count, disk size,\
+ \ memory size, number of CPUs) but got %d: '%s'" (length es) desc
-- | Creates a node group with the given specifications.
createGroup :: Int -- ^ The group index
@@ -72,10 +71,10 @@ createGroup :: Int -- ^ The group index
createGroup grpIndex spec = do
(apol, ncount, disk, mem, cpu) <- parseDesc spec
let nodes = map (\idx ->
- Node.create (printf "node-%02d-%03d" grpIndex idx)
- (fromIntegral mem) 0 mem
- (fromIntegral disk) disk
- (fromIntegral cpu) False grpIndex
+ Node.create (printf "node-%02d-%03d" grpIndex idx)
+ (fromIntegral mem) 0 mem
+ (fromIntegral disk) disk
+ (fromIntegral cpu) False grpIndex
) [1..ncount]
grp = Group.create (printf "group-%02d" grpIndex)
(printf "fake-uuid-%02d" grpIndex) apol
diff --git a/htools/Ganeti/HTools/Text.hs b/htools/Ganeti/HTools/Text.hs
index 8958f9f58631a3c1feb2d6599a92f5f394fb85b5..e16692478b275952680c3aced2b327f6db997b72 100644
--- a/htools/Ganeti/HTools/Text.hs
+++ b/htools/Ganeti/HTools/Text.hs
@@ -27,16 +27,15 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.HTools.Text
- (
- loadData
- , parseData
- , loadInst
- , loadNode
- , serializeInstances
- , serializeNode
- , serializeNodes
- , serializeCluster
- ) where
+ ( loadData
+ , parseData
+ , loadInst
+ , loadNode
+ , serializeInstances
+ , serializeNode
+ , serializeNodes
+ , serializeCluster
+ ) where
import Control.Monad
import Data.List
@@ -56,8 +55,8 @@ import qualified Ganeti.HTools.Instance as Instance
-- | Serialize a single group.
serializeGroup :: Group.Group -> String
serializeGroup grp =
- printf "%s|%s|%s" (Group.name grp) (Group.uuid grp)
- (allocPolicyToRaw (Group.allocPolicy grp))
+ printf "%s|%s|%s" (Group.name grp) (Group.uuid grp)
+ (allocPolicyToRaw (Group.allocPolicy grp))
-- | Generate group file data from a group list.
serializeGroups :: Group.List -> String
@@ -68,11 +67,11 @@ serializeNode :: Group.List -- ^ The list of groups (needed for group uuid)
-> Node.Node -- ^ The node to be serialised
-> String
serializeNode gl node =
- printf "%s|%.0f|%d|%d|%.0f|%d|%.0f|%c|%s" (Node.name node)
- (Node.tMem node) (Node.nMem node) (Node.fMem node)
- (Node.tDsk node) (Node.fDsk node) (Node.tCpu node)
- (if Node.offline node then 'Y' else 'N')
- (Group.uuid grp)
+ printf "%s|%.0f|%d|%d|%.0f|%d|%.0f|%c|%s" (Node.name node)
+ (Node.tMem node) (Node.nMem node) (Node.fMem node)
+ (Node.tDsk node) (Node.fDsk node) (Node.tCpu node)
+ (if Node.offline node then 'Y' else 'N')
+ (Group.uuid grp)
where grp = Container.find (Node.group node) gl
-- | Generate node file data from node objects.
@@ -85,25 +84,23 @@ serializeInstance :: Node.List -- ^ The node list (needed for
-> Instance.Instance -- ^ The instance to be serialised
-> String
serializeInstance nl inst =
- let
- iname = Instance.name inst
- pnode = Container.nameOf nl (Instance.pNode inst)
- sidx = Instance.sNode inst
- snode = (if sidx == Node.noSecondary
- then ""
- else Container.nameOf nl sidx)
- in
- printf "%s|%d|%d|%d|%s|%s|%s|%s|%s|%s"
- iname (Instance.mem inst) (Instance.dsk inst)
- (Instance.vcpus inst) (instanceStatusToRaw (Instance.runSt inst))
- (if Instance.autoBalance inst then "Y" else "N")
- pnode snode (diskTemplateToRaw (Instance.diskTemplate inst))
- (intercalate "," (Instance.tags inst))
+ let iname = Instance.name inst
+ pnode = Container.nameOf nl (Instance.pNode inst)
+ sidx = Instance.sNode inst
+ snode = (if sidx == Node.noSecondary
+ then ""
+ else Container.nameOf nl sidx)
+ in printf "%s|%d|%d|%d|%s|%s|%s|%s|%s|%s"
+ iname (Instance.mem inst) (Instance.dsk inst)
+ (Instance.vcpus inst) (instanceStatusToRaw (Instance.runSt inst))
+ (if Instance.autoBalance inst then "Y" else "N")
+ pnode snode (diskTemplateToRaw (Instance.diskTemplate inst))
+ (intercalate "," (Instance.tags inst))
-- | Generate instance file data from instance objects.
serializeInstances :: Node.List -> Instance.List -> String
serializeInstances nl =
- unlines . map (serializeInstance nl) . Container.elems
+ unlines . map (serializeInstance nl) . Container.elems
-- | Generate complete cluster data from node and instance lists.
serializeCluster :: ClusterData -> String
diff --git a/htools/Ganeti/HTools/Types.hs b/htools/Ganeti/HTools/Types.hs
index a3719d8dd9fe1adf9e286c65ebf509eb54ac9550..208686bfe28820c5f92589f9abdd2f9255875c1e 100644
--- a/htools/Ganeti/HTools/Types.hs
+++ b/htools/Ganeti/HTools/Types.hs
@@ -26,51 +26,51 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.HTools.Types
- ( Idx
- , Ndx
- , Gdx
- , NameAssoc
- , Score
- , Weight
- , GroupID
- , AllocPolicy(..)
- , allocPolicyFromRaw
- , allocPolicyToRaw
- , InstanceStatus(..)
- , instanceStatusFromRaw
- , instanceStatusToRaw
- , RSpec(..)
- , DynUtil(..)
- , zeroUtil
- , baseUtil
- , addUtil
- , subUtil
- , defVcpuRatio
- , defReservedDiskRatio
- , unitMem
- , unitCpu
- , unitDsk
- , unknownField
- , Placement
- , IMove(..)
- , DiskTemplate(..)
- , diskTemplateToRaw
- , diskTemplateFromRaw
- , MoveJob
- , JobSet
- , Result(..)
- , isOk
- , isBad
- , eitherToResult
- , Element(..)
- , FailMode(..)
- , FailStats
- , OpResult(..)
- , opToResult
- , connTimeout
- , queryTimeout
- , EvacMode(..)
- ) where
+ ( Idx
+ , Ndx
+ , Gdx
+ , NameAssoc
+ , Score
+ , Weight
+ , GroupID
+ , AllocPolicy(..)
+ , allocPolicyFromRaw
+ , allocPolicyToRaw
+ , InstanceStatus(..)
+ , instanceStatusFromRaw
+ , instanceStatusToRaw
+ , RSpec(..)
+ , DynUtil(..)
+ , zeroUtil
+ , baseUtil
+ , addUtil
+ , subUtil
+ , defVcpuRatio
+ , defReservedDiskRatio
+ , unitMem
+ , unitCpu
+ , unitDsk
+ , unknownField
+ , Placement
+ , IMove(..)
+ , DiskTemplate(..)
+ , diskTemplateToRaw
+ , diskTemplateFromRaw
+ , MoveJob
+ , JobSet
+ , Result(..)
+ , isOk
+ , isBad
+ , eitherToResult
+ , Element(..)
+ , FailMode(..)
+ , FailStats
+ , OpResult(..)
+ , opToResult
+ , connTimeout
+ , queryTimeout
+ , EvacMode(..)
+ ) where
import Control.Monad
import qualified Data.Map as M
@@ -107,40 +107,40 @@ type GroupID = String
-- changing this data type be careful about the interaction with the
-- desired sorting order.
$(THH.declareSADT "AllocPolicy"
- [ ("AllocPreferred", 'C.allocPolicyPreferred)
- , ("AllocLastResort", 'C.allocPolicyLastResort)
- , ("AllocUnallocable", 'C.allocPolicyUnallocable)
- ])
+ [ ("AllocPreferred", 'C.allocPolicyPreferred)
+ , ("AllocLastResort", 'C.allocPolicyLastResort)
+ , ("AllocUnallocable", 'C.allocPolicyUnallocable)
+ ])
$(THH.makeJSONInstance ''AllocPolicy)
-- | The Instance real state type.
$(THH.declareSADT "InstanceStatus"
- [ ("AdminDown", 'C.inststAdmindown)
- , ("AdminOffline", 'C.inststAdminoffline)
- , ("ErrorDown", 'C.inststErrordown)
- , ("ErrorUp", 'C.inststErrorup)
- , ("NodeDown", 'C.inststNodedown)
- , ("NodeOffline", 'C.inststNodeoffline)
- , ("Running", 'C.inststRunning)
- , ("WrongNode", 'C.inststWrongnode)
- ])
+ [ ("AdminDown", 'C.inststAdmindown)
+ , ("AdminOffline", 'C.inststAdminoffline)
+ , ("ErrorDown", 'C.inststErrordown)
+ , ("ErrorUp", 'C.inststErrorup)
+ , ("NodeDown", 'C.inststNodedown)
+ , ("NodeOffline", 'C.inststNodeoffline)
+ , ("Running", 'C.inststRunning)
+ , ("WrongNode", 'C.inststWrongnode)
+ ])
$(THH.makeJSONInstance ''InstanceStatus)
-- | The resource spec type.
data RSpec = RSpec
- { rspecCpu :: Int -- ^ Requested VCPUs
- , rspecMem :: Int -- ^ Requested memory
- , rspecDsk :: Int -- ^ Requested disk
- } deriving (Show, Read, Eq)
+ { rspecCpu :: Int -- ^ Requested VCPUs
+ , rspecMem :: Int -- ^ Requested memory
+ , rspecDsk :: Int -- ^ Requested disk
+ } deriving (Show, Read, Eq)
-- | The dynamic resource specs of a machine (i.e. load or load
-- capacity, as opposed to size).
data DynUtil = DynUtil
- { cpuWeight :: Weight -- ^ Standardised CPU usage
- , memWeight :: Weight -- ^ Standardised memory load
- , dskWeight :: Weight -- ^ Standardised disk I\/O usage
- , netWeight :: Weight -- ^ Standardised network usage
- } deriving (Show, Read, Eq)
+ { cpuWeight :: Weight -- ^ Standardised CPU usage
+ , memWeight :: Weight -- ^ Standardised memory load
+ , dskWeight :: Weight -- ^ Standardised disk I\/O usage
+ , netWeight :: Weight -- ^ Standardised network usage
+ } deriving (Show, Read, Eq)
-- | Initial empty utilisation.
zeroUtil :: DynUtil
@@ -156,12 +156,12 @@ baseUtil = DynUtil { cpuWeight = 1, memWeight = 1
-- | Sum two utilisation records.
addUtil :: DynUtil -> DynUtil -> DynUtil
addUtil (DynUtil a1 a2 a3 a4) (DynUtil b1 b2 b3 b4) =
- DynUtil (a1+b1) (a2+b2) (a3+b3) (a4+b4)
+ DynUtil (a1+b1) (a2+b2) (a3+b3) (a4+b4)
-- | Substracts one utilisation record from another.
subUtil :: DynUtil -> DynUtil -> DynUtil
subUtil (DynUtil a1 a2 a3 a4) (DynUtil b1 b2 b3 b4) =
- DynUtil (a1-b1) (a2-b2) (a3-b3) (a4-b4)
+ DynUtil (a1-b1) (a2-b2) (a3-b3) (a4-b4)
-- | The description of an instance placement. It contains the
-- instance index, the new primary and secondary node, the move being
@@ -178,13 +178,13 @@ data IMove = Failover -- ^ Failover the instance (f)
-- | Instance disk template type.
$(THH.declareSADT "DiskTemplate"
- [ ("DTDiskless", 'C.dtDiskless)
- , ("DTFile", 'C.dtFile)
- , ("DTSharedFile", 'C.dtSharedFile)
- , ("DTPlain", 'C.dtPlain)
- , ("DTBlock", 'C.dtBlock)
- , ("DTDrbd8", 'C.dtDrbd8)
- ])
+ [ ("DTDiskless", 'C.dtDiskless)
+ , ("DTFile", 'C.dtFile)
+ , ("DTSharedFile", 'C.dtSharedFile)
+ , ("DTPlain", 'C.dtPlain)
+ , ("DTBlock", 'C.dtBlock)
+ , ("DTDrbd8", 'C.dtDrbd8)
+ ])
$(THH.makeJSONInstance ''DiskTemplate)
-- | Formatted solution output for one move (involved nodes and
@@ -237,18 +237,18 @@ data Result a
deriving (Show, Read, Eq)
instance Monad Result where
- (>>=) (Bad x) _ = Bad x
- (>>=) (Ok x) fn = fn x
- return = Ok
- fail = Bad
+ (>>=) (Bad x) _ = Bad x
+ (>>=) (Ok x) fn = fn x
+ return = Ok
+ fail = Bad
instance MonadPlus Result 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
+ 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
-- | Simple checker for whether a 'Result' is OK.
isOk :: Result a -> Bool
@@ -287,9 +287,9 @@ data OpResult a = OpFail FailMode -- ^ Failed operation
deriving (Show, Read)
instance Monad OpResult where
- (OpGood x) >>= fn = fn x
- (OpFail y) >>= _ = OpFail y
- return = OpGood
+ (OpGood x) >>= fn = fn x
+ (OpFail y) >>= _ = OpFail y
+ return = OpGood
-- | Conversion from 'OpResult' to 'Result'.
opToResult :: OpResult a -> Result a
@@ -298,27 +298,27 @@ opToResult (OpGood v) = Ok v
-- | A generic class for items that have updateable names and indices.
class Element a where
- -- | Returns the name of the element
- nameOf :: a -> String
- -- | Returns all the known names of the element
- allNames :: a -> [String]
- -- | Returns the index of the element
- idxOf :: a -> Int
- -- | Updates the alias of the element
- setAlias :: a -> String -> a
- -- | Compute the alias by stripping a given suffix (domain) from
- -- the name
- computeAlias :: String -> a -> a
- computeAlias dom e = setAlias e alias
- where alias = take (length name - length dom) name
- name = nameOf e
- -- | Updates the index of the element
- setIdx :: a -> Int -> a
+ -- | Returns the name of the element
+ nameOf :: a -> String
+ -- | Returns all the known names of the element
+ allNames :: a -> [String]
+ -- | Returns the index of the element
+ idxOf :: a -> Int
+ -- | Updates the alias of the element
+ setAlias :: a -> String -> a
+ -- | Compute the alias by stripping a given suffix (domain) from
+ -- the name
+ computeAlias :: String -> a -> a
+ computeAlias dom e = setAlias e alias
+ where alias = take (length name - length dom) name
+ name = nameOf e
+ -- | Updates the index of the element
+ setIdx :: a -> Int -> a
-- | The iallocator node-evacuate evac_mode type.
$(THH.declareSADT "EvacMode"
- [ ("ChangePrimary", 'C.iallocatorNevacPri)
- , ("ChangeSecondary", 'C.iallocatorNevacSec)
- , ("ChangeAll", 'C.iallocatorNevacAll)
- ])
+ [ ("ChangePrimary", 'C.iallocatorNevacPri)
+ , ("ChangeSecondary", 'C.iallocatorNevacSec)
+ , ("ChangeAll", 'C.iallocatorNevacAll)
+ ])
$(THH.makeJSONInstance ''EvacMode)
diff --git a/htools/Ganeti/HTools/Utils.hs b/htools/Ganeti/HTools/Utils.hs
index 4b0dd4ac4c815ba37fc31b563c60a850d247346d..c3b3caad9e45c04641a7b7dae59c9ec06e1c09aa 100644
--- a/htools/Ganeti/HTools/Utils.hs
+++ b/htools/Ganeti/HTools/Utils.hs
@@ -22,33 +22,32 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.HTools.Utils
- (
- debug
- , debugFn
- , debugXy
- , sepSplit
- , stdDev
- , if'
- , select
- , applyIf
- , commaJoin
- , readEitherString
- , JSRecord
- , loadJSArray
- , fromObj
- , fromObjWithDefault
- , maybeFromObj
- , tryFromObj
- , fromJVal
- , asJSObject
- , asObjectList
- , fromJResult
- , tryRead
- , formatTable
- , annotateResult
- , defaultGroupID
- , parseUnit
- ) where
+ ( debug
+ , debugFn
+ , debugXy
+ , sepSplit
+ , stdDev
+ , if'
+ , select
+ , applyIf
+ , commaJoin
+ , readEitherString
+ , JSRecord
+ , loadJSArray
+ , fromObj
+ , fromObjWithDefault
+ , maybeFromObj
+ , tryFromObj
+ , fromJVal
+ , asJSObject
+ , asObjectList
+ , fromJResult
+ , tryRead
+ , formatTable
+ , annotateResult
+ , defaultGroupID
+ , parseUnit
+ ) where
import Data.Char (toUpper)
import Data.List
@@ -88,12 +87,12 @@ commaJoin = intercalate ","
-- | Split a list on a separator and return an array.
sepSplit :: Eq a => a -> [a] -> [[a]]
sepSplit sep s
- | null s = []
- | null xs = [x]
- | null ys = [x,[]]
- | otherwise = x:sepSplit sep ys
- where (x, xs) = break (== sep) s
- ys = drop 1 xs
+ | null s = []
+ | null xs = [x]
+ | null ys = [x,[]]
+ | otherwise = x:sepSplit sep ys
+ where (x, xs) = break (== sep) s
+ ys = drop 1 xs
-- * Mathematical functions
@@ -135,7 +134,6 @@ select :: a -- ^ default result
-> a -- ^ first result which has a True condition, or default
select def = maybe def snd . find fst
-
-- | Annotate a Result with an ownership information.
annotateResult :: String -> Result a -> Result a
annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
@@ -195,22 +193,22 @@ defaultGroupID = "00000000-0000-0000-0000-000000000000"
-- value in MiB.
parseUnit :: (Monad m, Integral a, Read a) => String -> m a
parseUnit str =
- -- TODO: enhance this by splitting the unit parsing code out and
- -- accepting floating-point numbers
- case reads str of
- [(v, suffix)] ->
- let unit = dropWhile (== ' ') suffix
- upper = map toUpper unit
- siConvert x = x * 1000000 `div` 1048576
- in case () of
- _ | null unit -> return v
- | unit == "m" || upper == "MIB" -> return v
- | unit == "M" || upper == "MB" -> return $ siConvert v
- | unit == "g" || upper == "GIB" -> return $ v * 1024
- | unit == "G" || upper == "GB" -> return $ siConvert
- (v * 1000)
- | unit == "t" || upper == "TIB" -> return $ v * 1048576
- | unit == "T" || upper == "TB" -> return $
- siConvert (v * 1000000)
- | otherwise -> fail $ "Unknown unit '" ++ unit ++ "'"
- _ -> fail $ "Can't parse string '" ++ str ++ "'"
+ -- TODO: enhance this by splitting the unit parsing code out and
+ -- accepting floating-point numbers
+ case reads str of
+ [(v, suffix)] ->
+ let unit = dropWhile (== ' ') suffix
+ upper = map toUpper unit
+ siConvert x = x * 1000000 `div` 1048576
+ in case () of
+ _ | null unit -> return v
+ | unit == "m" || upper == "MIB" -> return v
+ | unit == "M" || upper == "MB" -> return $ siConvert v
+ | unit == "g" || upper == "GIB" -> return $ v * 1024
+ | unit == "G" || upper == "GB" -> return $ siConvert
+ (v * 1000)
+ | unit == "t" || upper == "TIB" -> return $ v * 1048576
+ | unit == "T" || upper == "TB" -> return $
+ siConvert (v * 1000000)
+ | otherwise -> fail $ "Unknown unit '" ++ unit ++ "'"
+ _ -> fail $ "Can't parse string '" ++ str ++ "'"
diff --git a/htools/Ganeti/Jobs.hs b/htools/Ganeti/Jobs.hs
index 1e2cebecccc14eea92cd9c85ccf9e8a21248a5dc..804c71331016dfbb23d41f5e0f720cc6ed63c645 100644
--- a/htools/Ganeti/Jobs.hs
+++ b/htools/Ganeti/Jobs.hs
@@ -26,9 +26,9 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.Jobs
- ( OpStatus(..)
- , JobStatus(..)
- ) where
+ ( OpStatus(..)
+ , JobStatus(..)
+ ) where
import Text.JSON (readJSON, showJSON, JSON)
import qualified Text.JSON as J
@@ -38,26 +38,26 @@ import qualified Ganeti.THH as THH
-- | Our ADT for the OpCode status at runtime (while in a job).
$(THH.declareSADT "OpStatus"
- [ ("OP_STATUS_QUEUED", 'C.opStatusQueued)
- , ("OP_STATUS_WAITING", 'C.opStatusWaiting)
- , ("OP_STATUS_CANCELING", 'C.opStatusCanceling)
- , ("OP_STATUS_RUNNING", 'C.opStatusRunning)
- , ("OP_STATUS_CANCELED", 'C.opStatusCanceled)
- , ("OP_STATUS_SUCCESS", 'C.opStatusSuccess)
- , ("OP_STATUS_ERROR", 'C.opStatusError)
- ])
+ [ ("OP_STATUS_QUEUED", 'C.opStatusQueued)
+ , ("OP_STATUS_WAITING", 'C.opStatusWaiting)
+ , ("OP_STATUS_CANCELING", 'C.opStatusCanceling)
+ , ("OP_STATUS_RUNNING", 'C.opStatusRunning)
+ , ("OP_STATUS_CANCELED", 'C.opStatusCanceled)
+ , ("OP_STATUS_SUCCESS", 'C.opStatusSuccess)
+ , ("OP_STATUS_ERROR", 'C.opStatusError)
+ ])
$(THH.makeJSONInstance ''OpStatus)
-- | The JobStatus data type. Note that this is ordered especially
-- such that greater\/lesser comparison on values of this type makes
-- sense.
$(THH.declareSADT "JobStatus"
- [ ("JOB_STATUS_QUEUED", 'C.jobStatusQueued)
- , ("JOB_STATUS_WAITING", 'C.jobStatusWaiting)
- , ("JOB_STATUS_CANCELING", 'C.jobStatusCanceling)
- , ("JOB_STATUS_RUNNING", 'C.jobStatusRunning)
- , ("JOB_STATUS_CANCELED", 'C.jobStatusCanceled)
- , ("JOB_STATUS_SUCCESS", 'C.jobStatusSuccess)
- , ("JOB_STATUS_ERROR", 'C.jobStatusError)
- ])
+ [ ("JOB_STATUS_QUEUED", 'C.jobStatusQueued)
+ , ("JOB_STATUS_WAITING", 'C.jobStatusWaiting)
+ , ("JOB_STATUS_CANCELING", 'C.jobStatusCanceling)
+ , ("JOB_STATUS_RUNNING", 'C.jobStatusRunning)
+ , ("JOB_STATUS_CANCELED", 'C.jobStatusCanceled)
+ , ("JOB_STATUS_SUCCESS", 'C.jobStatusSuccess)
+ , ("JOB_STATUS_ERROR", 'C.jobStatusError)
+ ])
$(THH.makeJSONInstance ''JobStatus)
diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs
index 70b2b20627ddb34c765b0a22b538a2628ee783e9..bdc466386e86acaee4ec021d3bb75d827b05dacd 100644
--- a/htools/Ganeti/Luxi.hs
+++ b/htools/Ganeti/Luxi.hs
@@ -26,17 +26,17 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.Luxi
- ( LuxiOp(..)
- , QrViaLuxi(..)
- , ResultStatus(..)
- , Client
- , checkRS
- , getClient
- , closeClient
- , callMethod
- , submitManyJobs
- , queryJobsStatus
- ) where
+ ( LuxiOp(..)
+ , QrViaLuxi(..)
+ , ResultStatus(..)
+ , Client
+ , checkRS
+ , getClient
+ , closeClient
+ , callMethod
+ , submitManyJobs
+ , queryJobsStatus
+ ) where
import Data.IORef
import Control.Monad
@@ -59,101 +59,101 @@ import Ganeti.THH
-- | Wrapper over System.Timeout.timeout that fails in the IO monad.
withTimeout :: Int -> String -> IO a -> IO a
withTimeout secs descr action = do
- result <- timeout (secs * 1000000) action
- (case result of
- Nothing -> fail $ "Timeout in " ++ descr
- Just v -> return v)
+ result <- timeout (secs * 1000000) action
+ (case result of
+ Nothing -> fail $ "Timeout in " ++ descr
+ Just v -> return v)
-- * Generic protocol functionality
$(declareSADT "QrViaLuxi"
- [ ("QRLock", 'qrLock)
- , ("QRInstance", 'qrInstance)
- , ("QRNode", 'qrNode)
- , ("QRGroup", 'qrGroup)
- , ("QROs", 'qrOs)
- ])
+ [ ("QRLock", 'qrLock)
+ , ("QRInstance", 'qrInstance)
+ , ("QRNode", 'qrNode)
+ , ("QRGroup", 'qrGroup)
+ , ("QROs", 'qrOs)
+ ])
$(makeJSONInstance ''QrViaLuxi)
-- | Currently supported Luxi operations and JSON serialization.
$(genLuxiOp "LuxiOp"
- [("Query" ,
- [ ("what", [t| QrViaLuxi |], [| id |])
- , ("fields", [t| [String] |], [| id |])
- , ("qfilter", [t| () |], [| const JSNull |])
- ])
- , ("QueryNodes",
- [ ("names", [t| [String] |], [| id |])
- , ("fields", [t| [String] |], [| id |])
- , ("lock", [t| Bool |], [| id |])
- ])
- , ("QueryGroups",
- [ ("names", [t| [String] |], [| id |])
- , ("fields", [t| [String] |], [| id |])
- , ("lock", [t| Bool |], [| id |])
- ])
- , ("QueryInstances",
- [ ("names", [t| [String] |], [| id |])
- , ("fields", [t| [String] |], [| id |])
- , ("lock", [t| Bool |], [| id |])
- ])
- , ("QueryJobs",
- [ ("ids", [t| [Int] |], [| map show |])
- , ("fields", [t| [String] |], [| id |])
- ])
- , ("QueryExports",
- [ ("nodes", [t| [String] |], [| id |])
- , ("lock", [t| Bool |], [| id |])
- ])
- , ("QueryConfigValues",
- [ ("fields", [t| [String] |], [| id |]) ]
- )
- , ("QueryClusterInfo", [])
- , ("QueryTags",
- [ ("kind", [t| String |], [| id |])
- , ("name", [t| String |], [| id |])
- ])
- , ("SubmitJob",
- [ ("job", [t| [OpCode] |], [| id |]) ]
- )
- , ("SubmitManyJobs",
- [ ("ops", [t| [[OpCode]] |], [| id |]) ]
- )
- , ("WaitForJobChange",
- [ ("job", [t| Int |], [| id |])
- , ("fields", [t| [String]|], [| id |])
- , ("prev_job", [t| JSValue |], [| id |])
- , ("prev_log", [t| JSValue |], [| id |])
- , ("tmout", [t| Int |], [| id |])
- ])
- , ("ArchiveJob",
- [ ("job", [t| Int |], [| show |]) ]
- )
- , ("AutoArchiveJobs",
- [ ("age", [t| Int |], [| id |])
- , ("tmout", [t| Int |], [| id |])
- ])
- , ("CancelJob",
- [ ("job", [t| Int |], [| show |]) ]
- )
- , ("SetDrainFlag",
- [ ("flag", [t| Bool |], [| id |]) ]
- )
- , ("SetWatcherPause",
- [ ("duration", [t| Double |], [| id |]) ]
- )
+ [("Query" ,
+ [ ("what", [t| QrViaLuxi |], [| id |])
+ , ("fields", [t| [String] |], [| id |])
+ , ("qfilter", [t| () |], [| const JSNull |])
+ ])
+ , ("QueryNodes",
+ [ ("names", [t| [String] |], [| id |])
+ , ("fields", [t| [String] |], [| id |])
+ , ("lock", [t| Bool |], [| id |])
+ ])
+ , ("QueryGroups",
+ [ ("names", [t| [String] |], [| id |])
+ , ("fields", [t| [String] |], [| id |])
+ , ("lock", [t| Bool |], [| id |])
+ ])
+ , ("QueryInstances",
+ [ ("names", [t| [String] |], [| id |])
+ , ("fields", [t| [String] |], [| id |])
+ , ("lock", [t| Bool |], [| id |])
+ ])
+ , ("QueryJobs",
+ [ ("ids", [t| [Int] |], [| map show |])
+ , ("fields", [t| [String] |], [| id |])
+ ])
+ , ("QueryExports",
+ [ ("nodes", [t| [String] |], [| id |])
+ , ("lock", [t| Bool |], [| id |])
+ ])
+ , ("QueryConfigValues",
+ [ ("fields", [t| [String] |], [| id |]) ]
+ )
+ , ("QueryClusterInfo", [])
+ , ("QueryTags",
+ [ ("kind", [t| String |], [| id |])
+ , ("name", [t| String |], [| id |])
+ ])
+ , ("SubmitJob",
+ [ ("job", [t| [OpCode] |], [| id |]) ]
+ )
+ , ("SubmitManyJobs",
+ [ ("ops", [t| [[OpCode]] |], [| id |]) ]
+ )
+ , ("WaitForJobChange",
+ [ ("job", [t| Int |], [| id |])
+ , ("fields", [t| [String]|], [| id |])
+ , ("prev_job", [t| JSValue |], [| id |])
+ , ("prev_log", [t| JSValue |], [| id |])
+ , ("tmout", [t| Int |], [| id |])
+ ])
+ , ("ArchiveJob",
+ [ ("job", [t| Int |], [| show |]) ]
+ )
+ , ("AutoArchiveJobs",
+ [ ("age", [t| Int |], [| id |])
+ , ("tmout", [t| Int |], [| id |])
+ ])
+ , ("CancelJob",
+ [ ("job", [t| Int |], [| show |]) ]
+ )
+ , ("SetDrainFlag",
+ [ ("flag", [t| Bool |], [| id |]) ]
+ )
+ , ("SetWatcherPause",
+ [ ("duration", [t| Double |], [| id |]) ]
+ )
])
-- | The serialisation of LuxiOps into strings in messages.
$(genStrOfOp ''LuxiOp "strOfOp")
$(declareIADT "ResultStatus"
- [ ("RSNormal", 'rsNormal)
- , ("RSUnknown", 'rsUnknown)
- , ("RSNoData", 'rsNodata)
- , ("RSUnavailable", 'rsUnavail)
- , ("RSOffline", 'rsOffline)
- ])
+ [ ("RSNormal", 'rsNormal)
+ , ("RSUnknown", 'rsUnknown)
+ , ("RSNoData", 'rsNodata)
+ , ("RSUnavailable", 'rsUnavail)
+ , ("RSOffline", 'rsOffline)
+ ])
$(makeJSONInstance ''ResultStatus)
@@ -186,11 +186,11 @@ data Client = Client { socket :: S.Socket -- ^ The socket of the client
-- | Connects to the master daemon and returns a luxi Client.
getClient :: String -> IO Client
getClient path = do
- s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
- withTimeout connTimeout "creating luxi connection" $
- S.connect s (S.SockAddrUnix path)
- rf <- newIORef ""
- return Client { socket=s, rbuf=rf}
+ s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
+ withTimeout connTimeout "creating luxi connection" $
+ S.connect s (S.SockAddrUnix path)
+ rf <- newIORef ""
+ return Client { socket=s, rbuf=rf}
-- | Closes the client socket.
closeClient :: Client -> IO ()
@@ -199,12 +199,12 @@ closeClient = S.sClose . socket
-- | Sends a message over a luxi transport.
sendMsg :: Client -> String -> IO ()
sendMsg s buf =
- let _send obuf = do
- sbytes <- withTimeout queryTimeout
- "sending luxi message" $
- S.send (socket s) obuf
- unless (sbytes == length obuf) $ _send (drop sbytes obuf)
- in _send (buf ++ [eOM])
+ let _send obuf = do
+ sbytes <- withTimeout queryTimeout
+ "sending luxi message" $
+ S.send (socket s) obuf
+ unless (sbytes == length obuf) $ _send (drop sbytes obuf)
+ in _send (buf ++ [eOM])
-- | Waits for a message over a luxi transport.
recvMsg :: Client -> IO String
@@ -229,11 +229,11 @@ recvMsg s = do
buildCall :: LuxiOp -- ^ The method
-> String -- ^ The serialized form
buildCall lo =
- let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue)
- , (strOfKey Args, opToArgs lo::JSValue)
- ]
- jo = toJSObject ja
- in encodeStrict jo
+ let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue)
+ , (strOfKey Args, opToArgs lo::JSValue)
+ ]
+ jo = toJSObject ja
+ in encodeStrict jo
-- | Check that luxi responses contain the required keys and that the
-- call was successful.
diff --git a/htools/Ganeti/OpCodes.hs b/htools/Ganeti/OpCodes.hs
index 187af13bd0beb49f0a2b1f1b5340d7a3dd68c5e2..4b54e21f23e6152c0a59022a36dc5dc7db2732f3 100644
--- a/htools/Ganeti/OpCodes.hs
+++ b/htools/Ganeti/OpCodes.hs
@@ -26,10 +26,10 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module Ganeti.OpCodes
- ( OpCode(..)
- , ReplaceDisksMode(..)
- , opID
- ) where
+ ( OpCode(..)
+ , ReplaceDisksMode(..)
+ , opID
+ ) where
import Text.JSON (readJSON, showJSON, makeObj, JSON)
import qualified Text.JSON as J
@@ -41,11 +41,11 @@ import Ganeti.HTools.Utils
-- | Replace disks type.
$(declareSADT "ReplaceDisksMode"
- [ ("ReplaceOnPrimary", 'C.replaceDiskPri)
- , ("ReplaceOnSecondary", 'C.replaceDiskSec)
- , ("ReplaceNewSecondary", 'C.replaceDiskChg)
- , ("ReplaceAuto", 'C.replaceDiskAuto)
- ])
+ [ ("ReplaceOnPrimary", 'C.replaceDiskPri)
+ , ("ReplaceOnSecondary", 'C.replaceDiskSec)
+ , ("ReplaceNewSecondary", 'C.replaceDiskChg)
+ , ("ReplaceAuto", 'C.replaceDiskAuto)
+ ])
$(makeJSONInstance ''ReplaceDisksMode)
-- | OpCode representation.
@@ -53,34 +53,34 @@ $(makeJSONInstance ''ReplaceDisksMode)
-- We only implement a subset of Ganeti opcodes, but only what we
-- actually use in the htools codebase.
$(genOpCode "OpCode"
- [ ("OpTestDelay",
- [ ("duration", [t| Double |], noDefault)
- , ("on_master", [t| Bool |], noDefault)
- , ("on_nodes", [t| [String] |], noDefault)
- ])
- , ("OpInstanceReplaceDisks",
- [ ("instance_name", [t| String |], noDefault)
- , ("remote_node", [t| Maybe String |], noDefault)
- , ("mode", [t| ReplaceDisksMode |], noDefault)
- , ("disks", [t| [Int] |], noDefault)
- , ("iallocator", [t| Maybe String |], noDefault)
- ])
- , ("OpInstanceFailover",
- [ ("instance_name", [t| String |], noDefault)
- , ("ignore_consistency", [t| Bool |], noDefault)
- , ("target_node", [t| Maybe String |], noDefault)
- ])
- , ("OpInstanceMigrate",
- [ ("instance_name", [t| String |], noDefault)
- , ("live", [t| Bool |], noDefault)
- , ("cleanup", [t| Bool |], noDefault)
- , ("allow_failover", [t| Bool |], [| Just False |])
- , ("target_node", [t| Maybe String |], noDefault)
- ])
- ])
+ [ ("OpTestDelay",
+ [ ("duration", [t| Double |], noDefault)
+ , ("on_master", [t| Bool |], noDefault)
+ , ("on_nodes", [t| [String] |], noDefault)
+ ])
+ , ("OpInstanceReplaceDisks",
+ [ ("instance_name", [t| String |], noDefault)
+ , ("remote_node", [t| Maybe String |], noDefault)
+ , ("mode", [t| ReplaceDisksMode |], noDefault)
+ , ("disks", [t| [Int] |], noDefault)
+ , ("iallocator", [t| Maybe String |], noDefault)
+ ])
+ , ("OpInstanceFailover",
+ [ ("instance_name", [t| String |], noDefault)
+ , ("ignore_consistency", [t| Bool |], noDefault)
+ , ("target_node", [t| Maybe String |], noDefault)
+ ])
+ , ("OpInstanceMigrate",
+ [ ("instance_name", [t| String |], noDefault)
+ , ("live", [t| Bool |], noDefault)
+ , ("cleanup", [t| Bool |], noDefault)
+ , ("allow_failover", [t| Bool |], [| Just False |])
+ , ("target_node", [t| Maybe String |], noDefault)
+ ])
+ ])
$(genOpID ''OpCode "opID")
instance JSON OpCode where
- readJSON = loadOpCode
- showJSON = saveOpCode
+ readJSON = loadOpCode
+ showJSON = saveOpCode
diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index 44e410a1d8ba27cac5b91fab9cd4828d69f2ae27..b3c97f68cffea595db55471ba149ee0983767e3d 100644
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -93,9 +93,9 @@ appFn f x | f == VarE 'id = x
-- The type will have a fixed list of instances.
strADTDecl :: Name -> [String] -> Dec
strADTDecl name constructors =
- DataD [] name []
- (map (flip NormalC [] . mkName) constructors)
- [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
+ DataD [] name []
+ (map (flip NormalC [] . mkName) constructors)
+ [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
-- | Generates a toRaw function.
--
diff --git a/htools/test.hs b/htools/test.hs
index 1c0c9aed0dd4d3de4123af77281fe9f391bcbe4e..0e51db5f1dfbc473bb93f53971eafdf5713aefb8 100644
--- a/htools/test.hs
+++ b/htools/test.hs
@@ -42,11 +42,11 @@ import Ganeti.HTools.Utils (sepSplit)
-- | Options list and functions.
options :: [OptType]
options =
- [ oReplay
- , oVerbose
- , oShowVer
- , oShowHelp
- ]
+ [ oReplay
+ , oVerbose
+ , oShowVer
+ , oShowHelp
+ ]
fast :: Args
fast = stdArgs
@@ -150,22 +150,22 @@ main = do
cmd_args <- System.getArgs
(opts, args) <- parseOpts cmd_args "test" options
tests <- (if null args
- then return allTests
- else (let args' = map lower args
- selected = filter ((`elem` args') . lower . extractName)
- allTests
- in if null selected
- then do
- hPutStrLn stderr $ "No tests matching '"
- ++ intercalate " " args ++ "', available tests: "
- ++ intercalate ", " (map extractName allTests)
- exitWith $ ExitFailure 1
- else return selected))
+ then return allTests
+ else (let args' = map lower args
+ selected = filter ((`elem` args') . lower .
+ extractName) allTests
+ in if null selected
+ then do
+ hPutStrLn stderr $ "No tests matching '"
+ ++ intercalate " " args ++ "', available tests: "
+ ++ intercalate ", " (map extractName allTests)
+ exitWith $ ExitFailure 1
+ else return selected))
let max_count = maximum $ map (\(_, (_, t)) -> length t) tests
mapM_ (\(targs, (name, tl)) ->
- transformTestOpts targs opts >>= \newargs ->
- runTests name newargs (wrap tl) max_count) tests
+ transformTestOpts targs opts >>= \newargs ->
+ runTests name newargs (wrap tl) max_count) tests
terr <- readIORef errs
(if terr > 0
then do