/ - Diff - snf-ganeti - Greek Research and Technology Network's projects

     {- | 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.
     -}
-...
     -}
     module Ganeti.HTools.Compat
         ( rwhnf
         , Control.Parallel.Strategies.parMap
         ) where
       ( rwhnf
       , Control.Parallel.Strategies.parMap
       ) where
     import qualified Control.Parallel.Strategies

     -}
     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
-...
     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

     -}
     module Ganeti.HTools.ExtLoader
         ( loadExternalData
         , commonSuffix
         , maybeSaveData
         ) where
       ( loadExternalData
       , commonSuffix
       , maybeSaveData
       ) where
     import Control.Monad
     import Data.Maybe (isJust, fromJust)
-...
     -- | 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
-...
                           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

     -}
     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
-...
     -- | 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)]
-...
     -- | 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.
     --

     -}
     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
-...
     -- | 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
-...
            -> [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.
     --
-...
     -- | 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.
     --

     -}
     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)
-...
     -- 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)
-...
     -- | 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) =>
-...
     -- | 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)

     -}
     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
-...
     -}
     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
-...
     -- | 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
-...
     -- | 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
-...
              -> 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)
-...
                   -> 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
-...
     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.
-...
     -- | 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

     -}
     module Ganeti.HTools.Luxi
+        (
           loadData
         , parseData
         ) where
       ( loadData
       , parseData
       ) where
     import qualified Control.Exception as E
     import Text.JSON.Types
-...
     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)]]
-...
     -- | 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.
-...
                    -> (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
-...
     -- | 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

     {-
     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
-...
     -}
     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
-...
     -- | 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

     -- | 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 ()

     -- | 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

     -}
     module Ganeti.HTools.QCHelper
         ( testSuite
         ) where
       ( testSuite
       ) where
     import Test.QuickCheck
     import Language.Haskell.TH

     {-# LANGUAGE BangPatterns, CPP #-}
     module Ganeti.HTools.Rapi
+        (
           loadData
         , parseData
         ) where
       ( loadData
       , parseData
       ) where
     import Data.Maybe (fromMaybe)
     #ifndef NO_CURL
-...
     -- | 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.
-...
                  -> 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

     -}
     module Ganeti.HTools.Simu
+        (
           loadData
         , parseData
         ) where
       ( loadData
       , parseData
       ) where
     import Control.Monad (mplus)
     import Text.Printf (printf)
-...
     -- | 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
-...
     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

     -}
     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
-...
     -- | 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
-...
                   -> 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.
-...
                       -> 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

     -}
     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
-...
     -- 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
-...
     -- | 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
-...
     -- | 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
-...
         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
-...
                       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
-...
     -- | 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

Synnefo » snf-ganeti

Revision ebf38064