Synnefo » snf-ganeti » ganeti-local

.PHONY: hlint

hlint: $(HS_BUILT_SRCS)

	if tty -s; then C="-c"; else C=""; fi; \

# a dist hook rule for updating the vcs-version file; this is

# hardcoded due to where it needs to build the file...

- `HsColour <http://hackage.haskell.org/package/hscolour>`_, again

  used for documentation (it's source-code pretty-printing)

- `hlint <http://community.haskell.org/~ndm/hlint/>`_, a source code

- the `QuickCheck <http://hackage.haskell.org/package/QuickCheck>`_

  library, version 2.x

- ``hpc``, which comes with the compiler, so you should already have

  make hlint

``doc/hs-lint.html``.

When writing or debugging TemplateHaskell code, it's useful to see

    (o, n, []) ->

      do

        let (pr, args) = (foldM (flip id) defaultOptions o, n)

        when (optShowHelp po) $ do

          putStr $ usageHelp progname options

          exitWith ExitSuccess

      m_cpu = optMcpu opts

      m_dsk = optMdsk opts

         hPrintf stderr "Error: Wrong node name(s) set as offline: %s\n"

                     (commaJoin (map lrContent offline_wrong)) :: IO ()

         exitWith $ ExitFailure 1

  let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst

      int_p = Node.removePri old_p inst

      int_s = Node.removeSec old_s inst

      new_nl = do -- Maybe monad

        new_s <- Node.addSec int_p inst old_sdx

        let new_inst = Instance.setBoth inst old_sdx old_pdx

        return (Container.addTwo old_pdx new_s old_sdx new_p nl,

checkInstanceMove nodes_idx disk_moves inst_moves ini_tbl target =

  let opdx = Instance.pNode target

      osdx = Instance.sNode target

      use_secondary = elem osdx nodes_idx && inst_moves

      aft_failover = if use_secondary -- if allowed to failover

                       then checkSingleStep ini_tbl target ini_tbl Failover

                 _ -> fs

      snl = sortBy (comparing Node.idx) (Container.elems nl)

      (header, isnum) = unzip $ map Node.showHeader fields

     formatTable (header:map (Node.list fields) snl) isnum

-- | Print the instance list.

      header = [ "F", "Name", "Pri_node", "Sec_node", "Auto_bal"

               , "vcpu", "mem" , "dsk", "lCpu", "lMem", "lDsk", "lNet" ]

      isnum = False:False:False:False:False:repeat True

     formatTable (header:map helper sil) isnum

-- | Shows statistics for a given node list.

                           " files options should be given.")

         exitWith $ ExitFailure 1

  let util_data = mapM parseUtilisation $ lines util_contents

  input_data <-

    case () of

      _ | setRapi -> wrapIO $ Rapi.loadData mhost

  let ldresult = input_data >>= mergeData util_data' exTags selInsts exInsts

  cdata <-

  let (fix_msgs, nl) = checkData (cdNodes cdata) (cdInstances cdata)

  unless (optVerbose opts == 0) $ maybeShowWarnings fix_msgs

import Ganeti.HTools.Utils

import Ganeti.HTools.Types

-- | Type alias for the result of an IAllocator call.

type IAllocResult = (String, JSValue, Node.List, Instance.List)

           else readEitherString $ head nodes

  pidx <- lookupNode ktn n pnode

  let snodes = tail nodes

  return (n, Instance.setBoth (snd base) pidx sidx)

-- | Parses a node as found in the cluster node list.

  vm_capable  <- annotateResult desc $ maybeFromObj a "vm_capable"

  let vm_capable' = fromMaybe True vm_capable

  gidx <- lookupGroup ktg n guuid

  return (n, node)

-- | Parses a group as found in the cluster group list.

            hPutStrLn stderr $ "Error: " ++ err

            exitWith $ ExitFailure 1

          Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq

-- | Main iallocator pipeline.

runIAllocator :: Request -> (Maybe (Node.List, Instance.List), String)

                        (Node.fMem node - adj_mem)

                 umsg1 =

                   if delta_mem > 512 || delta_dsk > 1024

                      else msgs

             in (umsg1, newn)

        ) [] nl

import Ganeti.HTools.Utils (fromJVal, annotateResult, tryFromObj, asJSObject,

                            fromObj)

-- * Utility functions

-- | Get values behind \"data\" part of the result.

  xname <- annotateResult "Parsing new instance" (fromJValWithStatus name)

  let convert a = genericConvert "Instance" xname a

  xdisk <- convert "disk_usage" disk

  xvcpus <- convert "be/vcpus" vcpus

  xpnode <- convert "pnode" pnode >>= lookupNode ktn xname

  xsnodes <- convert "snodes" snodes::Result [JSString]

  xrunning <- convert "status" status

  xtags <- convert "tags" tags

  xauto_balance <- convert "auto_balance" auto_balance

  xdrained <- convert "drained" drained

  xvm_capable <- convert "vm_capable" vm_capable

  xgdx   <- convert "group.uuid" g_uuid >>= lookupGroup ktg xname

  return (xname, node)

parseNode _ v = fail ("Invalid node query result: " ++ show v)

removeSec :: Node -> Instance.Instance -> Node

removeSec t inst =

  let iname = Instance.idx inst

      cur_dsk = fDsk t

      pnode = Instance.pNode inst

      new_slist = delete iname (sList t)

                  then cur_dsk + Instance.dsk inst

                  else cur_dsk

      old_peers = peers t

module Ganeti.HTools.Program.Hail (main) where

import Control.Monad

import System.Environment (getArgs)

import System.IO

  maybeSaveData savecluster "pre-ialloc" "before iallocator run" cdata

  let (maybe_ni, resp) = runIAllocator request

  putStrLn resp

  maybePrintNodes shownodes "Final cluster" (Cluster.printNodes fin_nl)

saveBalanceCommands opts cmd_data = do

  let out_path = fromJust $ optShowCmds opts

  putStrLn ""

-- | Polls a set of jobs at a fixed interval until all are finished

-- one way or another.

execWrapper _      _  _  _    [] = return True

execWrapper master nl il cref alljss = do

  cancel <- readIORef cref

-- | Execute an entire jobset.

execJobSet :: String -> Node.List

                putStrLn $ "Got job IDs " ++ commaJoin x

                waitForJobs client x

         )

-- | Executes the jobs, if possible and desired.

maybeExecJobs :: Options

        exitWith $ ExitFailure 1

      Just grp ->

          case lookup (Group.idx grp) ngroups of

              -- This will only happen if there are no nodes assigned

              -- to this group

              return (Group.name grp, (Container.empty, Container.empty))

  checkNeedRebalance opts ini_cv

  putStrLn "Trying to minimize the CV..."

  let imlen = maximum . map (length . Instance.alias) $ Container.elems il

printAllocationMap verbose msg nl ixes =

  when (verbose > 1) $ do

    hPutStrLn stderr (msg ++ " map")

            formatTable (map (printInstance nl) (reverse ixes))

                        -- This is the numberic-or-not field

                        -- specification; the first three fields are

            -> Node.List -> Node.List -> [(FailMode, Int)] -> IO ()

printTiered True spec_map m_cpu nl trl_nl _ = do

  printKeys $ printStats PTiered (Cluster.totalResources trl_nl)

  printAllocationStats m_cpu nl trl_nl

printTiered False spec_map _ ini_nl fin_nl sreason = do

  -- Run the tiered allocation, if enabled

           runAllocation cdata stop_allocation

  -- Run the standard (avg-mode) allocation

      (_, nlst) = Loader.assignIndices namelst

  in nlst

-- | Checks if a node is "big" enough.

isNodeBig :: Node.Node -> Int -> Bool

isNodeBig node size = Node.availDisk node > size * Types.unitDsk

                      , "OP_INSTANCE_FAILOVER"

                      , "OP_INSTANCE_MIGRATE"

                      ]

instance Arbitrary Jobs.OpStatus where

  arbitrary = elements [minBound..maxBound]

instance Arbitrary a => Arbitrary (Types.OpResult a) where

  arbitrary = arbitrary >>= \c ->

-- * Actual tests

-- not contain commas, then join+split should be idempotent.

prop_Utils_commaJoinSplit =

  forAll (arbitrary `suchThat`

  Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst

-- | Split and join should always be idempotent.

                  -> [Int]    -- ^ List of True values

                  -> Gen Prop -- ^ Test result

prop_Utils_select def lst1 lst2 =

  where expectedresult = Utils.if' (null lst2) def (head lst2)

        flist = map (\e -> (False, e)) lst1

        tlist = map (\e -> (True, e)) lst2

-- | Test basic select functionality with undefined default

prop_Utils_select_undefd :: [Int]            -- ^ List of False values

                         -> NonEmptyList Int -- ^ List of True values

                         -> Gen Prop         -- ^ Test result

prop_Utils_select_undefd lst1 (NonEmpty lst2) =

  where flist = map (\e -> (False, e)) lst1

        tlist = map (\e -> (True, e)) lst2

-- | Test basic select functionality with undefined list values

prop_Utils_select_undefv :: [Int]            -- ^ List of False values

-- ** Container tests

prop_Container_addTwo cdata i1 i2 =

  fn i1 i2 cont == fn i2 i1 cont &&

  fn i1 i2 cont == fn i1 i2 (fn i1 i2 cont)

  forAll (vector cnt) $ \ names ->

  (length . nub) (map fst names ++ map snd names) ==

  length names * 2 &&

  let nl = makeSmallCluster node cnt

      nodes = Container.elems nl

      nodes' = map (\((name, alias), nn) -> (Node.idx nn,

      target = snd (nodes' !! fidx)

  in Container.findByName nl' (Node.name target) == Just target &&

     Container.findByName nl' (Node.alias target) == Just target &&

testSuite "Container"

            [ 'prop_Container_addTwo

           -- this is not related to rMem, but as good a place to

           -- test as any

           inst_idx `elem` Node.sList a_ab &&

       x -> printTestCase ("Failed to add/remove instances: " ++ show x) False

-- | Check mdsk setting.

        && Node.availDisk node > 0

        && Node.availMem node > 0

        ==>

  in case Cluster.genAllocNodes defGroupList nl 2 True >>=

     Cluster.tryAlloc nl il inst' of

       Types.Bad _ -> False

        && not (Node.failN1 node)

        && isNodeBig node 4

        ==>

  in case Cluster.genAllocNodes defGroupList nl 2 True >>=

     Cluster.tryAlloc nl il inst' of

       Types.Bad _ -> False

import qualified Ganeti.HTools.Instance as Instance

import qualified Ganeti.Constants as C

-- | Read an URL via curl and return the body if successful.

getUrl :: (Monad m) => String -> IO (m String)

  disk <- extract "disk_usage" a

  beparams <- liftM fromJSObject (extract "beparams" a)

  omem <- extract "oper_ram" a

  vcpus <- extract "vcpus" beparams

  pnode <- extract "pnode" a >>= lookupNode ktn name

  snodes <- extract "snodes" a

  running <- extract "status" a

  tags <- extract "tags" a

  auto_balance <- extract "auto_balance" beparams

  let vm_cap' = fromMaybe True vm_cap

  guuid   <- annotateResult desc $ maybeFromObj a "group.uuid"

  guuid' <-  lookupGroup ktg name (fromMaybe defaultGroupID guuid)

  return (name, node)

-- | Construct a group from a JSON object.

loadInst ktn [ name, mem, dsk, vcpus, status, auto_bal, pnode, snode

             , dt, tags ] = do

  pidx <- lookupNode ktn name pnode

  vmem <- tryRead name mem

  vdsk <- tryRead name dsk

  vvcpus <- tryRead name vcpus

withTimeout :: Int -> String -> IO a -> IO a

withTimeout secs descr action = do

  result <- timeout (secs * 1000000) action

-- * Generic protocol functionality

              nbuf <- withTimeout queryTimeout "reading luxi response" $

                      S.recv (socket s) 4096

              let (msg, remaining) = break (eOM ==) nbuf

  cbuf <- readIORef $ rbuf s

  let (imsg, ibuf) = break (eOM ==) cbuf

  (msg, nbuf) <-

  writeIORef (rbuf s) nbuf

  return msg

  let arr = J.fromJSObject oarr

  status <- fromObj arr (strOfKey Success)::Result Bool

  let rkey = strOfKey Result

-- | Generic luxi method call.

callMethod :: LuxiOp -> Client -> IO (Result JSValue)

         Nothing -> return Nothing

         Just str -> do

           let vs = sepSplit ',' str

  return args { chatty = optVerbose opts > 1,

                replay = r

              }

  let wrap = map (wrapTest errs)

  cmd_args <- getArgs

  (opts, args) <- parseOpts cmd_args "test" options

  let max_count = maximum $ map (\(_, (_, t)) -> length t) tests

  mapM_ (\(targs, (name, tl)) ->

           transformTestOpts targs opts >>= \newargs ->

           runTests name newargs (wrap tl) max_count) tests

  terr <- readIORef errs