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

     {-| Implementation of command-line functions.
     This module holds the common cli-related functions for the binaries,
     separated into this module since Utils.hs is used in many other places
     and this is more IO oriented.
     This module holds the common command-line related functions for the
     binaries, separated into this module since "Ganeti.HTools.Utils" is
     used in many other places and this is more IO oriented.
     -}
-...
     import Ganeti.HTools.Types
     import Ganeti.HTools.Utils
     -- | The default value for the luxi socket
     -- * Constants
     -- | The default value for the luxi socket.
     --
     -- This is re-exported from the "Ganeti.Constants" module.
     defaultLuxiSocket :: FilePath
     defaultLuxiSocket = C.masterSocket
     -- * Data types
     -- | Command line options structure.
     data Options = Options
         { optDataFile    :: Maybe FilePath -- ^ Path to the cluster data file
-...
      , optVerbose     = 1
+     }
     -- | Abrreviation for the option type
     -- | Abrreviation for the option type.
     type OptType = OptDescr (Options -> Result Options)
     -- * Command line options
     oDataFile :: OptType
     oDataFile = Option "t" ["text-data"]
                 (ReqArg (\ f o -> Ok o { optDataFile = Just f }) "FILE")
-...
                (NoArg (\ opts -> Ok opts { optVerbose = optVerbose opts + 1 }))
                "increase the verbosity level"
     -- | Usage info
     -- * Functions
     -- | Usage info.
     usageHelp :: String -> [OptType] -> String
     usageHelp progname =
         usageInfo (printf "%s %s\nUsage: %s [OPTION...]"
                    progname Version.version progname)
     -- | Command line parser, using the 'options' structure.
     -- | Command line parser, using the 'Options' structure.
     parseOpts :: [String]               -- ^ The command line arguments
               -> String                 -- ^ The program name
               -> [OptType]              -- ^ The supported command line options

     {-| Implementation of cluster-wide logic.
     This module holds all pure cluster-logic; I\/O related functionality
     goes into the "Main" module for the individual binaries.
     goes into the /Main/ module for the individual binaries.
     -}
-...
     -- | A type denoting the valid allocation mode/pairs.
     --
     -- For a one-node allocation, this will be a @Left ['Node.Node']@,
     -- whereas for a two-node allocation, this will be a @Right
     -- [('Node.Node', 'Node.Node')]@.
     type AllocNodes = Either [Ndx] [(Ndx, Ndx)]
     -- | The empty solution we start with when computing allocations
     -- | The empty solution we start with when computing allocations.
     emptySolution :: AllocSolution
     emptySolution = AllocSolution { asFailures = [], asAllocs = 0
                                   , asSolutions = [], asLog = [] }
     -- | The complete state for the balancing solution
     -- | The complete state for the balancing solution.
     data Table = Table Node.List Instance.List Score [Placement]
                  deriving (Show, Read)
-...
+                         }
                 deriving (Show, Read)
     -- | Currently used, possibly to allocate, unallocable
     -- | Currently used, possibly to allocate, unallocable.
     type AllocStats = (RSpec, RSpec, RSpec)
     -- * Utility functions
-...
       in
         (bad_nodes, bad_instances)
     -- | Zero-initializer for the CStats type
     -- | Zero-initializer for the CStats type.
     emptyCStats :: CStats
     emptyCStats = CStats 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
     -- | Update stats with data from a new node
     -- | Update stats with data from a new node.
     updateCStats :: CStats -> Node.Node -> CStats
     updateCStats cs node =
         let CStats { csFmem = x_fmem, csFdsk = x_fdsk,
-...
                    (truncate t_dsk - fromIntegral f_idsk)
         in (rini, rfin, runa)
     -- | The names and weights of the individual elements in the CV list
     -- | The names and weights of the individual elements in the CV list.
     detailedCVInfo :: [(Double, String)]
     detailedCVInfo = [ (1,  "free_mem_cv")
                      , (1,  "free_disk_cv")
-...
     compCV :: Node.List -> Double
     compCV = sum . zipWith (*) detailedCVWeights . compDetailedCV
     -- | Compute online nodes from a Node.List
     -- | Compute online nodes from a 'Node.List'.
     getOnline :: Node.List -> [Node.Node]
     getOnline = filter (not . Node.offline) . Container.elems
     -- * hbal functions
     -- * Balancing functions
     -- | Compute best table. Note that the ordering of the arguments is important.
     compareTables :: Table -> Table -> Table
-...
            then ini_tbl -- no advancement
            else best_tbl
     -- | Check if we are allowed to go deeper in the balancing
     -- | Check if we are allowed to go deeper in the balancing.
     doNextBalance :: Table     -- ^ The starting table
                   -> Int       -- ^ Remaining length
                   -> Score     -- ^ Score at which to stop
-...
             ini_plc_len = length ini_plc
         in (max_rounds < 0 || ini_plc_len < max_rounds) && ini_cv > min_score
     -- | Run a balance move
     -- | Run a balance move.
     tryBalance :: Table       -- ^ The starting table
                -> Bool        -- ^ Allow disk moves
                -> Bool        -- ^ Allow instance moves
-...
     -- * Allocation functions
     -- | Build failure stats out of a list of failures
     -- | Build failure stats out of a list of failures.
     collapseFailures :: [FailMode] -> FailStats
     collapseFailures flst =
         map (\k -> (k, length $ filter (k ==) flst)) [minBound..maxBound]
     -- | Update current Allocation solution and failure stats with new
     -- elements
     -- elements.
     concatAllocs :: AllocSolution -> OpResult Node.AllocElement -> AllocSolution
     concatAllocs as (OpFail reason) = as { asFailures = reason : asFailures as }
-...
     sumAllocs (AllocSolution af aa as al) (AllocSolution bf ba bs bl) =
         AllocSolution (af ++ bf) (aa + ba) (as ++ bs) (al ++ bl)
     -- | Given a solution, generates a reasonable description for it
     -- | Given a solution, generates a reasonable description for it.
     describeSolution :: AllocSolution -> String
     describeSolution as =
       let fcnt = asFailures as
-...
                          " for node(s) %s") cv (asAllocs as) (length fcnt) freasons
                  (intercalate "/" . map Node.name $ nodes)
     -- | Annotates a solution with the appropriate string
     -- | Annotates a solution with the appropriate string.
     annotateSolution :: AllocSolution -> AllocSolution
     annotateSolution as = as { asLog = describeSolution as : asLog as }
-...
            then fail "No online nodes"
            else return $ annotateSolution sols
     -- | Given a group/result, describe it as a nice (list of) messages
     -- | Given a group/result, describe it as a nice (list of) messages.
     solutionDescription :: Group.List -> (Gdx, Result AllocSolution) -> [String]
     solutionDescription gl (groupId, result) =
       case result of
-...
     -- | From a list of possibly bad and possibly empty solutions, filter
     -- only the groups with a valid result. Note that the result will be
     -- reversed compared to the original list
     -- reversed compared to the original list.
     filterMGResults :: Group.List
                     -> [(Gdx, Result AllocSolution)]
                     -> [(Gdx, AllocSolution)]
-...
                            | unallocable gdx -> accu
                            | otherwise -> (gdx, sol):accu
     -- | Sort multigroup results based on policy and score
     -- | Sort multigroup results based on policy and score.
     sortMGResults :: Group.List
                  -> [(Gdx, AllocSolution)]
                  -> [(Gdx, AllocSolution)]
-...
                     Just v -> return v
       tryReloc nl il xid ncount ex_ndx
     -- | Change an instance's secondary node
     -- | Change an instance's secondary node.
     evacInstance :: (Monad m) =>
                     [Ndx]                      -- ^ Excluded nodes
                  -> Instance.List              -- ^ The current instance list
-...
           let sol = foldl' sumAllocs emptySolution results
           return $ annotateSolution sol
     -- | Recursively place instances on the cluster until we're out of space
     -- | Recursively place instances on the cluster until we're out of space.
     iterateAlloc :: Node.List
                  -> Instance.List
                  -> Instance.Instance
-...
                      _ -> Bad "Internal error: multiple solutions for single\
                               \ allocation"
     -- | The core of the tiered allocation mode
     -- | The core of the tiered allocation mode.
     tieredAlloc :: Node.List
                 -> Instance.List
                 -> Instance.Instance
-...
     -- * Node group functions
     -- | Computes the group of an instance
     -- | Computes the group of an instance.
     instanceGroup :: Node.List -> Instance.Instance -> Result Gdx
     instanceGroup nl i =
       let sidx = Instance.sNode i
-...
                     show pgroup ++ ", secondary " ++ show sgroup)
          else return pgroup
     -- | Computes the group of an instance per the primary node
     -- | Computes the group of an instance per the primary node.
     instancePriGroup :: Node.List -> Instance.Instance -> Gdx
     instancePriGroup nl i =
       let pnode = Container.find (Instance.pNode i) nl
       in  Node.group pnode
     -- | Compute the list of badly allocated instances (split across node
     -- groups)
     -- groups).
     findSplitInstances :: Node.List -> Instance.List -> [Instance.Instance]
     findSplitInstances nl =
       filter (not . isOk . instanceGroup nl) . Container.elems
     -- | Splits a cluster into the component node groups
     -- | Splits a cluster into the component node groups.
     splitCluster :: Node.List -> Instance.List ->
                     [(Gdx, (Node.List, Instance.List))]
     splitCluster nl il =

     {-| External data loader
     {-| External data loader.
     This module holds the external data loading, and thus is the only one
     depending (via the specialized Text\/Rapi\/Luxi modules) on the actual
-...
     import Ganeti.HTools.CLI
     import Ganeti.HTools.Utils (sepSplit, tryRead)
     -- | Error beautifier
     -- | Error beautifier.
     wrapIO :: IO (Result a) -> IO (Result a)
     wrapIO = flip catch (return . Bad . show)

       let running = "running"
       return (n, Instance.create n mem disk vcpus running tags True 0 0)
     -- | Parses an instance as found in the cluster instance listg.
     -- | Parses an instance as found in the cluster instance list.
     parseInstance :: NameAssoc -- ^ The node name-to-index association list
                   -> String    -- ^ The name of the instance
                   -> JSRecord  -- ^ The JSON object

     -- * Type declarations
     -- | The instance type
     -- | The instance type.
     data Instance = Instance
         { name         :: String    -- ^ The instance name
         , alias        :: String    -- ^ The shortened name
-...
         setIdx   = setIdx
         allNames n = [name n, alias n]
     -- | Running instance states.
     -- | Constant holding the running instance states.
     runningStates :: [String]
     runningStates = [C.inststRunning, C.inststErrorup]

     {-| Generic data loader
     {-| Generic data loader.
     This module holds the common code for parsing the input data after it
     has been loaded from external sources.
-...
     -- * Constants
     -- | The exclusion tag prefix
     -- | The exclusion tag prefix.
     exTagsPrefix :: String
     exTagsPrefix = "htools:iextags:"
-...
                in Container.add sdx snew ac2
           else ac2
     -- | Remove non-selected tags from the exclusion list
     -- | Remove non-selected tags from the exclusion list.
     filterExTags :: [String] -> Instance.Instance -> Instance.Instance
     filterExTags tl inst =
         let old_tags = Instance.tags inst
-...
                        old_tags
         in inst { Instance.tags = new_tags }
     -- | Update the movable attribute
     -- | Update the movable attribute.
     updateMovable :: [String]           -- ^ Selected instances (if not empty)
                   -> [String]           -- ^ Excluded instances
                   -> Instance.Instance  -- ^ Target Instance
-...
         else inst
     -- | Compute the longest common suffix of a list of strings that
     -- | starts with a dot.
     -- starts with a dot.
     longestDomain :: [String] -> String
     longestDomain [] = ""
     longestDomain (x:xs) =
-...
                                   else accu)
           "" $ filter (isPrefixOf ".") (tails x)
     -- | Extracts the exclusion tags from the cluster configuration
     -- | Extracts the exclusion tags from the cluster configuration.
     extractExTags :: [String] -> [String]
     extractExTags =
         map (drop (length exTagsPrefix)) .
         filter (isPrefixOf exTagsPrefix)
     -- | Extracts the common suffix from node\/instance names
     -- | 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

     -- * Main loader functionality
     -- | Builds the cluster data from an URL.
     -- | Builds the cluster data by querying a given socket name.
     readData :: String -- ^ Unix socket to use as source
              -> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
     readData master =
-...
               return (groups, nodes, instances, cinfo)
+           )
     -- | Converts the output of 'readData' into the internal cluster
     -- representation.
     parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
               -> Result ClusterData
     parseData (groups, nodes, instances, cinfo) = do
-...
       ctags <- cinfo >>= getClusterTags
       return (ClusterData group_idx node_idx inst_idx ctags)
     -- | Top level function for data loading
     -- | Top level function for data loading.
     loadData :: String -- ^ Unix socket to use as source
              -> IO (Result ClusterData)
     loadData = fmap parseData . readData

     -- * Type declarations
     -- | The tag map type
     -- | The tag map type.
     type TagMap = Map.Map String Int
     -- | The node type.
-...
     type List = Container.Container Node
     -- | A simple name for an allocation element (here just for logistic
     -- reasons)
     -- reasons).
     type AllocElement = (List, Instance.Instance, [Node], T.Score)
     -- | Constant node index for a non-moveable instance.
-...
     -- * Helper functions
     -- | Add a tag to a tagmap
     -- | Add a tag to a tagmap.
     addTag :: TagMap -> String -> TagMap
     addTag t s = Map.insertWith (+) s 1 t
     -- | Add multiple tags
     -- | Add multiple tags.
     addTags :: TagMap -> [String] -> TagMap
     addTags = foldl' addTag
     -- | Adjust or delete a tag from a tagmap
     -- | Adjust or delete a tag from a tagmap.
     delTag :: TagMap -> String -> TagMap
     delTag t s = Map.update (\v -> if v > 1
                                    then Just (v-1)
                                    else Nothing)
                  s t
     -- | Remove multiple tags
     -- | Remove multiple tags.
     delTags :: TagMap -> [String] -> TagMap
     delTags = foldl' delTag
     -- | Check if we can add a list of tags to a tagmap
     -- | Check if we can add a list of tags to a tagmap.
     rejectAddTags :: TagMap -> [String] -> Bool
     rejectAddTags t = any (`Map.member` t)
-...
              , group = group_init
+             }
     -- | Conversion formula from mDsk\/tDsk to loDsk
     -- | Conversion formula from mDsk\/tDsk to loDsk.
     mDskToloDsk :: Double -> Double -> Int
     mDskToloDsk mval tdsk = floor (mval * tdsk)
     -- | Conversion formula from mCpu\/tCpu to hiCpu
     -- | Conversion formula from mCpu\/tCpu to hiCpu.
     mCpuTohiCpu :: Double -> Double -> Int
     mCpuTohiCpu mval tcpu = floor (mval * tcpu)
-...
     setXmem :: Node -> Int -> Node
     setXmem t val = t { xMem = val }
     -- | Sets the max disk usage ratio
     -- | Sets the max disk usage ratio.
     setMdsk :: Node -> Double -> Node
     setMdsk t val = t { mDsk = val, loDsk = mDskToloDsk val (tDsk t) }
     -- | Sets the max cpu usage ratio
     -- | Sets the max cpu usage ratio.
     setMcpu :: Node -> Double -> Node
     setMcpu t val = t { mCpu = val, hiCpu = mCpuTohiCpu val (tCpu t) }
-...
     -- * Stats functions
     -- | Computes the amount of available disk on a given node
     -- | Computes the amount of available disk on a given node.
     availDisk :: Node -> Int
     availDisk t =
         let _f = fDsk t
-...
            then 0
            else _f - _l
     -- | Computes the amount of used disk on a given node
     -- | Computes the amount of used disk on a given node.
     iDsk :: Node -> Int
     iDsk t = truncate (tDsk t) - fDsk t
     -- | Computes the amount of available memory on a given node
     -- | Computes the amount of available memory on a given node.
     availMem :: Node -> Int
     availMem t =
         let _f = fMem t
-...
            then 0
            else _f - _l
     -- | Computes the amount of available memory on a given node
     -- | Computes the amount of available memory on a given node.
     availCpu :: Node -> Int
     availCpu t =
         let _u = uCpu t
-...
     -- * Display functions
     showField :: Node -> String -> String
     -- | Return a field for a given node.
     showField :: Node   -- ^ Node which we're querying
               -> String -- ^ Field name
               -> String -- ^ Field value as string
     showField t field =
         case field of
           "idx"  -> printf "%4d" $ idx t
-...
           T.DynUtil { T.cpuWeight = uC, T.memWeight = uM,
                       T.dskWeight = uD, T.netWeight = uN } = utilLoad t
     -- | Returns the header and numeric propery of a field
     -- | Returns the header and numeric propery of a field.
     showHeader :: String -> (String, Bool)
     showHeader field =
         case field of
-...
     list fields t = map (showField t) fields
     -- | Constant holding the fields we're displaying by default.
     defaultFields :: [String]
     defaultFields =
         [ "status", "name", "tmem", "nmem", "imem", "xmem", "fmem"
-...
         , "cload", "mload", "dload", "nload" ]
     -- | Split a list of nodes into a list of (node group UUID, list of
     -- associated nodes)
     -- associated nodes).
     computeGroups :: [Node] -> [(T.Gdx, [Node])]
     computeGroups nodes =
       let nodes' = sortBy (comparing group) nodes

     {-|
       Module abstracting the peer map implementation.
     {-| Module abstracting the peer map implementation.
     This is abstracted separately since the speed of peermap updates can
     be a significant part of the total runtime, and as such changing the
-...
     import Ganeti.HTools.Types
     -- * Type definitions
     -- | Our key type.
     type Key = Ndx
     -- | Our element type.
     type Elem = Int
     -- | The definition of a peer map.
     type PeerMap = [(Key, Elem)]
     -- * Initialization functions
-...
           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
     -- | Create a PeerMap from an association list, with possible duplicates.
     accumArray :: (Elem -> Elem -> Elem) -- ^ function used to merge the elements
                   -> [(Key, Elem)]       -- ^ source data
                   -> PeerMap             -- ^ results
-...
     -- * Basic operations
     -- | Returns either the value for a key or zero if not found
     -- | Returns either the value for a key or zero if not found.
     find :: Key -> PeerMap -> Elem
     find k = fromMaybe 0 . lookup k
     -- | Add an element to a peermap, overwriting the previous value
     -- | Add an element to a peermap, overwriting the previous value.
     add :: Key -> Elem -> PeerMap -> PeerMap
     add = addWith (flip const)
     -- | Remove an element from a peermap
     -- | Remove an element from a peermap.
     remove :: Key -> PeerMap -> PeerMap
     remove _ [] = []
     remove k ((x@(x', _)):xs) = if k == x'

     {-| Unittests for ganeti-htools
     {-| Unittests for ganeti-htools.
     -}
-...
     -- * Constants
     -- | Maximum memory (1TiB, somewhat random value)
     -- | Maximum memory (1TiB, somewhat random value).
     maxMem :: Int
     maxMem = 1024 * 1024
     -- | Maximum disk (8TiB, somewhat random value)
     -- | Maximum disk (8TiB, somewhat random value).
     maxDsk :: Int
     maxDsk = 1024 * 1024 * 8
     -- | Max CPUs (1024, somewhat random value)
     -- | Max CPUs (1024, somewhat random value).
     maxCpu :: Int
     maxCpu = 1024
-...
     -- * Helper functions
     -- | Simple checker for whether OpResult is fail or pass
     -- | Simple checker for whether OpResult is fail or pass.
     isFailure :: Types.OpResult a -> Bool
     isFailure (Types.OpFail _) = True
     isFailure _ = False
     -- | Update an instance to be smaller than a node
     -- | Update an instance to be smaller than a node.
     setInstanceSmallerThanNode node inst =
         inst { Instance.mem = Node.availMem node `div` 2
              , Instance.dsk = Node.availDisk node `div` 2
              , Instance.vcpus = Node.availCpu node `div` 2
+             }
     -- | Create an instance given its spec
     -- | Create an instance given its spec.
     createInstance mem dsk vcpus =
         Instance.create "inst-unnamed" mem dsk vcpus "running" [] True (-1) (-1)
     -- | Create a small cluster by repeating a node spec
     -- | Create a small cluster by repeating a node spec.
     makeSmallCluster :: Node.Node -> Int -> Node.List
     makeSmallCluster node count =
         let fn = Node.buildPeers node Container.empty
-...
             (_, nlst) = Loader.assignIndices namelst
         in nlst
     -- | Checks if a node is "big" enough
     -- | Checks if a node is "big" enough.
     isNodeBig :: Node.Node -> Int -> Bool
     isNodeBig node size = Node.availDisk node > size * Types.unitDsk
                           && Node.availMem node > size * Types.unitMem
-...
     canBalance tbl dm im evac = isJust $ Cluster.tryBalance tbl dm im evac 0 0
     -- | Assigns a new fresh instance to a cluster; this is not
     -- allocation, so no resource checks are done
     -- allocation, so no resource checks are done.
     assignInstance :: Node.List -> Instance.List -> Instance.Instance ->
                       Types.Idx -> Types.Idx ->
                       (Node.List, Instance.List)
-...
     -- * Arbitrary instances
     -- | Defines a DNS name.
     newtype DNSChar = DNSChar { dnsGetChar::Char }
     instance Arbitrary DNSChar where
         arbitrary = do
           x <- elements (['a'..'z'] ++ ['0'..'9'] ++ "_-")
-...
           vcpus <- choose (0, maxCpu)
           return $ Instance.create name mem dsk vcpus run_st [] True pn sn
     genNode :: Maybe Int -> Maybe Int -> Gen Node.Node
     -- | Generas an arbitrary node based on sizing information.
     genNode :: Maybe Int -- ^ Minimum node size in terms of units
             -> Maybe Int -- ^ Maximum node size (when Nothing, bounded
                          -- just by the max... constants)
             -> Gen Node.Node
     genNode min_multiplier max_multiplier = do
       let (base_mem, base_dsk, base_cpu) =
               case min_multiplier of
-...
     instance Arbitrary Jobs.JobStatus where
       arbitrary = elements [minBound..maxBound]
     newtype SmallRatio = SmallRatio Double deriving Show
     instance Arbitrary SmallRatio where
         arbitrary = do
           v <- choose (0, 1)
           return $ SmallRatio v
     -- * Actual tests
     -- If the list is not just an empty element, and if the elements do
     -- not contain commas, then join+split should be idepotent
     -- ** Utils tests
     -- | If the list is not just an empty element, and if the elements do
     -- not contain commas, then join+split should be idempotent.
     prop_Utils_commaJoinSplit =
         forAll (arbitrary `suchThat`
                 (\l -> l /= [""] && all (not . elem ',') l )) $ \lst ->
         Utils.sepSplit ',' (Utils.commaJoin lst) == lst
     -- Split and join should always be idempotent
     -- | Split and join should always be idempotent.
     prop_Utils_commaSplitJoin s = Utils.commaJoin (Utils.sepSplit ',' s) == s
     -- | fromObjWithDefault, we test using the Maybe monad and an integer
     -- value
     -- value.
     prop_Utils_fromObjWithDefault def_value random_key =
         -- a missing key will be returned with the default
         Utils.fromObjWithDefault [] random_key def_value == Just def_value &&
-...
              random_key (def_value+1) == Just def_value
             where _types = def_value :: Integer
     -- | Test list for the Utils module.
     testUtils =
       [ run prop_Utils_commaJoinSplit
       , run prop_Utils_commaSplitJoin
       , run prop_Utils_fromObjWithDefault
+      ]
     -- | Make sure add is idempotent
     -- ** PeerMap tests
     -- | Make sure add is idempotent.
     prop_PeerMap_addIdempotent pmap key em =
         fn puniq == fn (fn puniq)
         where _types = (pmap::PeerMap.PeerMap,
-...
               fn = PeerMap.add key em
               puniq = PeerMap.accumArray const pmap
     -- | Make sure remove is idempotent
     -- | Make sure remove is idempotent.
     prop_PeerMap_removeIdempotent pmap key =
         fn puniq == fn (fn puniq)
         where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key)
               fn = PeerMap.remove key
               puniq = PeerMap.accumArray const pmap
     -- | Make sure a missing item returns 0
     -- | Make sure a missing item returns 0.
     prop_PeerMap_findMissing pmap key =
         PeerMap.find key (PeerMap.remove key puniq) == 0
         where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key)
               puniq = PeerMap.accumArray const pmap
     -- | Make sure an added item is found
     -- | Make sure an added item is found.
     prop_PeerMap_addFind pmap key em =
         PeerMap.find key (PeerMap.add key em puniq) == em
         where _types = (pmap::PeerMap.PeerMap,
                         key::PeerMap.Key, em::PeerMap.Elem)
               puniq = PeerMap.accumArray const pmap
     -- | Manual check that maxElem returns the maximum indeed, or 0 for null
     -- | Manual check that maxElem returns the maximum indeed, or 0 for null.
     prop_PeerMap_maxElem pmap =
         PeerMap.maxElem puniq == if null puniq then 0
                                  else (maximum . snd . unzip) puniq
         where _types = pmap::PeerMap.PeerMap
               puniq = PeerMap.accumArray const pmap
     -- | List of tests for the PeerMap module.
     testPeerMap =
         [ run prop_PeerMap_addIdempotent
         , run prop_PeerMap_removeIdempotent
-...
         , run prop_PeerMap_findMissing
+        ]
     -- Container tests
     -- ** Container tests
     prop_Container_addTwo cdata i1 i2 =
         fn i1 i2 cont == fn i2 i1 cont &&
-...
           fnode = head (Container.elems nl)
       in Container.nameOf nl (Node.idx fnode) == Node.name fnode
     -- We test that in a cluster, given a random node, we can find it by
     -- | We test that in a cluster, given a random node, we can find it by
     -- its name and alias, as long as all names and aliases are unique,
     -- and that we fail to find a non-existing name
     -- and that we fail to find a non-existing name.
     prop_Container_findByName node othername =
       forAll (choose (1, 20)) $ \ cnt ->
       forAll (choose (0, cnt - 1)) $ \ fidx ->
-...
         , run prop_Container_findByName
+        ]
     -- ** Instance tests
     -- Simple instance tests, we only have setter/getters
     prop_Instance_creat inst =
-...
         , run prop_Instance_setMovable
+        ]
     -- ** Text backend tests
     -- Instance text loader tests
     prop_Text_Load_Instance name mem dsk vcpus status
-...
         , run prop_Text_NodeLSIdempotent
+        ]
     -- Node tests
     -- ** Node tests
     prop_Node_setAlias node name =
         Node.name newnode == Node.name node &&
-...
         Node.mCpu newnode == mc
         where newnode = Node.setMcpu node mc
     -- | Check that an instance add with too high memory or disk will be rejected
     -- | Check that an instance add with too high memory or disk will be
     -- rejected.
     prop_Node_addPriFM node inst = Instance.mem inst >= Node.fMem node &&
                                    not (Node.failN1 node)
                                    ==>
-...
               inst' = setInstanceSmallerThanNode node inst
               inst'' = inst' { Instance.vcpus = Node.availCpu node + extra }
     -- | Check that an instance add with too high memory or disk will be rejected
     -- | Check that an instance add with too high memory or disk will be
     -- rejected.
     prop_Node_addSec node inst pdx =
         (Instance.mem inst >= (Node.fMem node - Node.rMem node) ||
          Instance.dsk inst >= Node.fDsk node) &&
-...
         ==> isFailure (Node.addSec node inst pdx)
             where _types = (node::Node.Node, inst::Instance.Instance, pdx::Int)
     -- | Checks for memory reservation changes
     -- | Checks for memory reservation changes.
     prop_Node_rMem inst =
         forAll (arbitrary `suchThat` ((> 0) . Node.fMem)) $ \node ->
         -- ab = auto_balance, nb = non-auto_balance
-...
              x -> printTestCase ("Failed to add/remove instances: " ++ show x)
                   False
     newtype SmallRatio = SmallRatio Double deriving Show
     instance Arbitrary SmallRatio where
         arbitrary = do
           v <- choose (0, 1)
           return $ SmallRatio v
     -- | Check mdsk setting
     -- | Check mdsk setting.
     prop_Node_setMdsk node mx =
         Node.loDsk node' >= 0 &&
         fromIntegral (Node.loDsk node') <= Node.tDsk node &&
-...
+        ]
     -- Cluster tests
     -- ** Cluster tests
     -- | Check that the cluster score is close to zero for a homogeneous cluster
     -- | Check that the cluster score is close to zero for a homogeneous
     -- cluster.
     prop_Score_Zero node =
         forAll (choose (1, 1024)) $ \count ->
         (not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
-...
         -- this should be much lower than the default score in CLI.hs
         in score <= 1e-12
     -- | Check that cluster stats are sane
     -- | Check that cluster stats are sane.
     prop_CStats_sane node =
         forAll (choose (1, 1024)) $ \count ->
         (not (Node.offline node) && not (Node.failN1 node) &&
-...
            Cluster.csAdsk cstats <= Cluster.csFdsk cstats
     -- | Check that one instance is allocated correctly, without
     -- rebalances needed
     -- rebalances needed.
     prop_ClusterAlloc_sane node inst =
         forAll (choose (5, 20)) $ \count ->
         not (Node.offline node)
-...
     -- | Checks that on a 2-5 node cluster, we can allocate a random
     -- instance spec via tiered allocation (whatever the original instance
     -- spec), on either one or two nodes
     -- spec), on either one or two nodes.
     prop_ClusterCanTieredAlloc node inst =
         forAll (choose (2, 5)) $ \count ->
         forAll (choose (1, 2)) $ \rqnodes ->
-...
                                           length ixes == length cstats
     -- | Checks that on a 4-8 node cluster, once we allocate an instance,
     -- we can also evacuate it
     -- we can also evacuate it.
     prop_ClusterAllocEvac node inst =
         forAll (choose (4, 8)) $ \count ->
         not (Node.offline node)
-...
                    _ -> False
     -- | Check that allocating multiple instances on a cluster, then
     -- adding an empty node, results in a valid rebalance
     -- adding an empty node, results in a valid rebalance.
     prop_ClusterAllocBalance =
         forAll (genNode (Just 5) (Just 128)) $ \node ->
         forAll (choose (3, 5)) $ \count ->
-...
                            tbl = Cluster.Table ynl il' cv []
                        in canBalance tbl True True False
     -- | Checks consistency
     -- | Checks consistency.
     prop_ClusterCheckConsistency node inst =
       let nl = makeSmallCluster node 3
           [node1, node2, node3] = Container.elems nl
-...
          null (ccheck [(0, inst2)]) &&
          (not . null $ ccheck [(0, inst3)])
     -- For now, we only test that we don't lose instances during the split
     -- | For now, we only test that we don't lose instances during the split.
     prop_ClusterSplitCluster node inst =
       forAll (choose (0, 100)) $ \icnt ->
       let nl = makeSmallCluster node 2
-...
         , run prop_ClusterSplitCluster
+        ]
     -- | Check that opcode serialization is idempotent
     -- ** OpCodes tests
     -- | Check that opcode serialization is idempotent.
     prop_OpCodes_serialization op =
       case J.readJSON (J.showJSON op) of
         J.Error _ -> False
-...
       [ run prop_OpCodes_serialization
+      ]
     -- | Check that (queued) job\/opcode status serialization is idempotent
     -- ** Jobs tests
     -- | Check that (queued) job\/opcode status serialization is idempotent.
     prop_OpStatus_serialization os =
       case J.readJSON (J.showJSON os) of
         J.Error _ -> False
-...
       , run prop_JobStatus_serialization
+      ]
     -- | Loader tests
     -- ** Loader tests
     prop_Loader_lookupNode ktn inst node =
       Loader.lookupNode nl inst node == Data.Map.lookup node nl
-...
        else True)
       where (nassoc, kt) = Loader.assignIndices (map (\n -> (Node.name n, n)) nodes)
     -- | Checks that the number of primary instances recorded on the nodes
     -- is zero
     -- is zero.
     prop_Loader_mergeData ns =
       let na = Container.fromList $ map (\n -> (Node.idx n, n)) ns
       in case Loader.mergeData [] [] [] []

     #else
     -- | The curl options we use
     -- | The curl options we use.
     curlOpts :: [CurlOption]
     curlOpts = [ CurlSSLVerifyPeer False
                , CurlSSLVerifyHost 0
-...
     getGroups body = loadJSArray "Parsing group data" body >>=
                     mapM (parseGroup . fromJSObject)
     -- | Generates a fake group list.
     getFakeGroups :: Result [(String, Group.Group)]
     getFakeGroups =
       return [(defaultGroupID,
-...
       tags_body <- getUrl $ printf "%s/2/tags" url
       return (group_body, node_body, inst_body, tags_body)
     -- | Builds the cluster data from the raw Rapi content
     -- | Builds the cluster data from the raw Rapi content.
     parseData :: (Result String, Result String, Result String, Result String)
               -> Result ClusterData
     parseData (group_body, node_body, inst_body, tags_body) = do
-...
       tags_data <- tags_body >>= (fromJResult "Parsing tags data" . decodeStrict)
       return (ClusterData group_idx node_idx inst_idx tags_data)
     -- | Top level function for data loading
     -- | Top level function for data loading.
     loadData :: String -- ^ Cluster or URL to use as source
              -> IO (Result ClusterData)
     loadData = fmap parseData . readData

b/htools/Ganeti/HTools/Simu.hs
1		{-\| Parsing data from a simulated description of the cluster
	1	{-\| Parsing data from a simulated description of the cluster.
2	2
3	3	This module holds the code for parsing a cluster description.
4	4

     {-| Parsing data from text-files
     {-| Parsing data from text-files.
     This module holds the code for loading the cluster state from text
     files, as produced by gnt-node and gnt-instance list.
     files, as produced by @gnt-node@ and @gnt-instance@ @list@ command.
     -}
-...
     import qualified Ganeti.HTools.Node as Node
     import qualified Ganeti.HTools.Instance as Instance
     -- | Serialize a single group
     -- * Serialisation functions
     -- | Serialize a single group.
     serializeGroup :: Group.Group -> String
     serializeGroup grp =
         printf "%s|%s|%s" (Group.name grp) (Group.uuid grp)
                    (apolToString (Group.allocPolicy grp))
     -- | Generate group file data from a group list
     -- | Generate group file data from a group list.
     serializeGroups :: Group.List -> String
     serializeGroups = unlines . map serializeGroup . Container.elems
     -- | Serialize a single node
     serializeNode :: Group.List -> Node.Node -> String
     -- | Serialize a single node.
     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)
-...
                    (Group.uuid grp)
         where grp = Container.find (Node.group node) gl
     -- | Generate node file data from node objects
     -- | Generate node file data from node objects.
     serializeNodes :: Group.List -> Node.List -> String
     serializeNodes gl = unlines . map (serializeNode gl) . Container.elems
     -- | Serialize a single instance
     serializeInstance :: Node.List -> Instance.Instance -> String
     -- | Serialize a single instance.
     serializeInstance :: Node.List         -- ^ The node list (needed for
                                            -- node names)
                       -> Instance.Instance -- ^ The instance to be serialised
                       -> String
     serializeInstance nl inst =
         let
             iname = Instance.name inst
-...
                  (if Instance.auto_balance inst then "Y" else "N")
                  pnode snode (intercalate "," (Instance.tags inst))
     -- | Generate instance file data from instance objects
     -- | Generate instance file data from instance objects.
     serializeInstances :: Node.List -> Instance.List -> String
     serializeInstances nl =
         unlines . map (serializeInstance nl) . Container.elems
     -- | Generate complete cluster data from node and instance lists
     -- | Generate complete cluster data from node and instance lists.
     serializeCluster :: ClusterData -> String
     serializeCluster (ClusterData gl nl il ctags) =
       let gdata = serializeGroups gl
-...
       -- note: not using 'unlines' as that adds too many newlines
       in intercalate "\n" [gdata, ndata, idata, unlines ctags]
     -- * Parsing functions
     -- | Load a group from a field list.
     loadGroup :: (Monad m) => [String] -> m (String, Group.Group)
     loadGroup :: (Monad m) => [String]
               -> m (String, Group.Group) -- ^ The result, a tuple of group
                                          -- UUID and group object
     loadGroup [name, gid, apol] = do
       xapol <- apolFromString apol
       return (gid, Group.create name gid xapol)
-...
     loadGroup s = fail $ "Invalid/incomplete group data: '" ++ show s ++ "'"
     -- | Load a node from a field list.
     loadNode :: (Monad m) => NameAssoc -> [String] -> m (String, Node.Node)
     loadNode :: (Monad m) =>
                 NameAssoc             -- ^ Association list with current groups
              -> [String]              -- ^ Input data as a list of fields
              -> m (String, Node.Node) -- ^ The result, a tuple o node name
                                       -- and node object
     loadNode ktg [name, tm, nm, fm, td, fd, tc, fo, gu] = do
       gdx <- lookupGroup ktg name gu
       new_node <-
-...
     -- | Load an instance from a field list.
     loadInst :: (Monad m) =>
                 NameAssoc -> [String] -> m (String, Instance.Instance)
                 NameAssoc                     -- ^ Association list with
                                               -- the current nodes
              -> [String]                      -- ^ Input data as a list of
                                               -- fields
              -> m (String, Instance.Instance) -- ^ The result, a tuple of
                                               -- instance name and the
                                               -- instance object
     loadInst ktn [name, mem, dsk, vcpus, status, auto_bal, pnode, snode, tags] = do
       pidx <- lookupNode ktn name pnode
       sidx <- (if null snode then return Node.noSecondary
-...
     -- @gnt-instance list@ and @gnt-node list@ to a list of objects using
     -- a supplied conversion function.
     loadTabular :: (Monad m, Element a) =>
                    [String] -> ([String] -> m (String, a))
                 -> m (NameAssoc, Container.Container a)
                    [String] -- ^ Input data, as a list of lines
                 -> ([String] -> m (String, a)) -- ^ Conversion function
                 -> m ( NameAssoc
                      , Container.Container a ) -- ^ A tuple of an
                                                -- association list (name
                                                -- to object) and a set as
                                                -- used in
                                                -- "Ganeti.HTools.Container"
     loadTabular lines_data convert_fn = do
       let rows = map (sepSplit '|') lines_data
       kerows <- mapM convert_fn rows
       return $ assignIndices kerows
     -- | Load the cluser data from disk.
     readData :: String -- ^ Path to the text file
              -> IO String
     --
     -- This is an alias to 'readFile' just for consistency with the other
     -- modules.
     readData :: String    -- ^ Path to the text file
              -> IO String -- ^ Contents of the file
     readData = readFile
     -- | Builds the cluster data from text input.
-...
       {- the tags are simply line-based, no processing needed -}
       return (ClusterData gl nl il ctags)
     -- | Top level function for data loading
     -- | Top level function for data loading.
     loadData :: String -- ^ Path to the text file
              -> IO (Result ClusterData)
     loadData = fmap parseData . readData

                            -- allocations
           deriving (Show, Read, Eq, Ord)
     -- | Convert a string to an alloc policy
     -- | Convert a string to an alloc policy.
     apolFromString :: (Monad m) => String -> m AllocPolicy
     apolFromString s =
         case () of
-...
             | s == C.allocPolicyUnallocable -> return AllocUnallocable
             | otherwise -> fail $ "Invalid alloc policy mode: " ++ s
     -- | Convert an alloc policy to the Ganeti string equivalent
     -- | Convert an alloc policy to the Ganeti string equivalent.
     apolToString :: AllocPolicy -> String
     apolToString AllocPreferred   = C.allocPolicyPreferred
     apolToString AllocLastResort  = C.allocPolicyLastResort
-...
         , netWeight :: Weight -- ^ Standardised network usage
         } deriving (Show, Read, Eq)
     -- | Initial empty utilisation
     -- | Initial empty utilisation.
     zeroUtil :: DynUtil
     zeroUtil = DynUtil { cpuWeight = 0, memWeight = 0
                        , dskWeight = 0, netWeight = 0 }
     -- | Base utilisation (used when no actual utilisation data is
     -- supplied).
     baseUtil :: DynUtil
     baseUtil = DynUtil { cpuWeight = 1, memWeight = 1
                        , dskWeight = 1, netWeight = 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)
     -- | 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)
-...
     -- performed and the score of the cluster after the move.
     type Placement = (Idx, Ndx, Ndx, IMove, Score)
     -- | An instance move definition
     -- | An instance move definition.
     data IMove = Failover                -- ^ Failover the instance (f)
                | ReplacePrimary Ndx      -- ^ Replace primary (f, r:np, f)
                | ReplaceSecondary Ndx    -- ^ Replace secondary (r:ns)
-...
                  deriving (Show, Read)
     -- | Formatted solution output for one move (involved nodes and
     -- commands
     -- commands.
     type MoveJob = ([Ndx], Idx, IMove, [String])
     -- | Unknown field in table output
     -- | Unknown field in table output.
     unknownField :: String
     unknownField = "<unknown field>"
     -- | A list of command elements
     -- | A list of command elements.
     type JobSet = [MoveJob]
     -- | Connection timeout (when using non-file methods).
-...
     {-|
     This is similar to the JSON library Result type - *very* similar, but
     This is similar to the JSON library Result type - /very/ similar, but
     we want to use it in multiple places, so we abstract it into a
     mini-library here
-...
         return = Ok
         fail = Bad
     -- | Simple checker for whether Result is OK
     -- | Simple checker for whether a 'Result' is OK.
     isOk :: Result a -> Bool
     isOk (Ok _) = True
     isOk _ = False
     -- | Simple checker for whether Result is a failure
     -- | Simple checker for whether a 'Result' is a failure.
     isBad :: Result a  -> Bool
     isBad = not . isOk
     -- | Reason for an operation's falure
     -- | Reason for an operation's falure.
     data FailMode = FailMem  -- ^ Failed due to not enough RAM
                   | FailDisk -- ^ Failed due to not enough disk
                   | FailCPU  -- ^ Failed due to not enough CPU capacity
-...
                   | FailTags -- ^ Failed due to tag exclusion
                     deriving (Eq, Enum, Bounded, Show, Read)
     -- | List with failure statistics
     -- | List with failure statistics.
     type FailStats = [(FailMode, Int)]
     -- | Either-like data-type customized for our failure modes
     -- | Either-like data-type customized for our failure modes.
     data OpResult a = OpFail FailMode -- ^ Failed operation
                     | OpGood a        -- ^ Success operation
                       deriving (Show, Read)
-...
         -- | Updates the alias of the element
         setAlias :: a -> String -> a
         -- | Compute the alias by stripping a given suffix (domain) from
         -- | the name
         -- the name
         computeAlias :: String -> a -> a
         computeAlias dom e = setAlias e alias
             where alias = take (length name - length dom) name

     {-| Utility functions -}
     {-| Utility functions. -}
     {-
-...
     debug :: Show a => a -> a
     debug x = trace (show x) x
     -- | Displays a modified form of the second parameter before returning it
     -- | Displays a modified form of the second parameter before returning
     -- it.
     debugFn :: Show b => (a -> b) -> a -> a
     debugFn fn x = debug (fn x) `seq` x
     -- | Show the first parameter before returning the second one
     -- | Show the first parameter before returning the second one.
     debugXy :: Show a => a -> b -> b
     debugXy a b = debug a `seq` b
     -- * Miscelaneous
     -- * Miscellaneous
     -- | Comma-join a string list.
     commaJoin :: [String] -> String
-...
     -- Simple and slow statistical functions, please replace with better
     -- versions
     -- | Standard deviation function
     -- | Standard deviation function.
     stdDev :: [Double] -> Double
     stdDev lst =
       -- first, calculate the list length and sum lst in a single step,
-...
     -- * JSON-related functions
     -- | A type alias for the list-based representation of J.JSObject
     -- | A type alias for the list-based representation of J.JSObject.
     type JSRecord = [(String, J.JSValue)]
     -- | Converts a JSON Result into a monadic value.
-...
                           JSRecord -> String -> a -> m a
     fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
     -- | Reads a JValue, that originated from an object key
     -- | Reads a JValue, that originated from an object key.
     fromKeyValue :: (J.JSON a, Monad m)
                   => String     -- ^ The key name
                   -> J.JSValue  -- ^ The value to read
-...
     fromKeyValue k val =
       fromJResult (printf "key '%s', value '%s'" k (show val)) (J.readJSON val)
     -- | Annotate a Result with an ownership information
     -- | Annotate a Result with an ownership information.
     annotateResult :: String -> Result a -> Result a
     annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
     annotateResult _ v = v
     -- | Try to extract a key from a object with better error reporting
     -- than fromObj
     -- than fromObj.
     tryFromObj :: (J.JSON a) =>
                   String     -- ^ Textual "owner" in error messages
                -> JSRecord   -- ^ The object array
-...
     -- * Parsing utility functions
     -- | Parse results from readsPrec
     -- | Parse results from readsPrec.
     parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
     parseChoices _ _ ((v, ""):[]) = return v
     parseChoices name s ((_, e):[]) =
-...
     tryRead :: (Monad m, Read a) => String -> String -> m a
     tryRead name s = parseChoices name s $ reads s
     -- | Format a table of strings to maintain consistent length
     -- | Format a table of strings to maintain consistent length.
     formatTable :: [[String]] -> [Bool] -> [[String]]
     formatTable vals numpos =
         let vtrans = transpose vals  -- transpose, so that we work on rows
-...
                         ) (zip3 vtrans numpos mlens)
        in transpose expnd
     -- | Default group UUID (just a string, not a real UUID)
     -- | Default group UUID (just a string, not a real UUID).
     defaultGroupID :: GroupID
     defaultGroupID = "00000000-0000-0000-0000-000000000000"

b/htools/Ganeti/Jobs.hs
33	33
34	34	import qualified Ganeti.Constants as C
35	35
	36	-- \| Our ADT for the OpCode status at runtime (while in a job).
36	37	data OpStatus = OP_STATUS_QUEUED
37	38	\| OP_STATUS_WAITLOCK
38	39	\| OP_STATUS_CANCELING

b/htools/Ganeti/Luxi.hs
161	161	writeIORef (rbuf s) nbuf
162	162	return msg
163	163
164		-- \| Compute the serialized form of a Luxi operation
	164	-- \| Compute the serialized form of a Luxi operation.
165	165	opToArgs :: LuxiOp -> JSValue

Synnefo » snf-ganeti

Revision 525bfb36