Synnefo » snf-ganeti

	$(PEP8) --ignore='$(PEP8_IGNORE)' --exclude='$(PEP8_EXCLUDE)' \

		--repeat $(pep8_python_code)

.PHONY: hlint

hlint: $(HS_BUILT_SRCS) htools/lint-hints.hs

	@test -n "$(HLINT)" || { echo 'hlint' not found during configure; exit 1; }

	  --ignore "Use comparing" \

	  --ignore "Use on" \

	  --ignore "Reduce duplication" \

	  --hint htools/lint-hints \

	  $(filter-out htools/Ganeti/THH.hs,$(HS_LIB_SRCS))

-- converts them to strings anyway, as they're used as dict-keys.

$(buildObject "ConfdReqQ" "confdReqQ"

                optionalField $ simpleField C.confdReqqIp [t| String   |]

                defaultField [| [] |] $

                simpleField C.confdReqqIplist [t| [String] |]

                simpleField C.confdReqqLink [t| String   |]

                simpleField C.confdReqqFields [t| [ConfdReqField] |]

  ])

import Control.Concurrent

import Control.Exception

import qualified Data.ByteString as B

import Data.IORef

import Data.List

import qualified Data.Map as M

import qualified Network.Socket as S

import Prelude hiding (catch)

import System.Posix.Files

buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipByInstPip

                                  , confdRqQuery = DictQuery query}) =

  let (cfg, linkipmap) = cdata

  in case confdReqQIp query of

       Just ip -> return $ getNodePipByInstanceIp cfg linkipmap link ip

       Nothing -> return (ReplyStatusOk,

-- | Wrapper over 'buildFileStatus'. This reads the data from the

-- filesystem and then builds our cache structure.

getFStat :: FilePath -> IO FStat

-- | Check if the file needs reloading

needsReload :: FStat -> FilePath -> IO (Maybe FStat)

onReloadTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO ()

onReloadTimer inotiaction path cref state = do

  continue <- modifyMVar state (onReloadInner inotiaction path cref)

-- | Inner onReload handler.

--

                   _            -> True

  return (state' { reloadModel = newmode }, continue)

-- | Setup inotify watcher.

--

-- This tries to setup the watch descriptor; in case of any IO errors,

    , instNodes

    ) where

import Data.List (foldl')

import qualified Data.Map as M

import qualified Data.Set as S

-- | Looks up an instance's primary node.

getInstPrimaryNode :: ConfigData -> String -> Result Node

getInstPrimaryNode cfg name =

-- | Filters DRBD minors for a given node.

getDrbdMinorsForNode :: String -> Disk -> [(Int, String)]

  when (optShowHelp opts) $ do

    putStr $ usageHelp progname options

  when (optShowVer opts) $ do

    printf "%s %s\ncompiled with %s %s\nrunning on %s %s\n"

           progname Version.version

           compilerName (Data.Version.showVersion compilerVersion)

           os arch :: IO ()

  exitUnless (null args) "This program doesn't take any arguments"

    let no_nodes = Left "no nodes available"

        node_pairs = [(p,s) | p <- avail_nodes, s <- avail_nodes, p /= s]

    (nl', il', ops, _) <-

        eitherToResult $

        foldl'

        (\accu nodes -> case evacDrbdAllInner nl il inst gdx nodes of

             MirrorNone -> Bad "Can't relocate/evacuate non-mirrored instances"

             MirrorInternal -> Ok ReplaceSecondary

             MirrorExternal -> Ok FailoverToAny

                          eitherToResult $

                          foldl' (evacOneNodeInner nl inst gdx op_fn)

                          (Left "no nodes available") avail_nodes

    if Node.offline primary

      then do

        (nl', inst', _, _) <-

          opToResult $ applyMove nl inst Failover

        return (nl', inst', [Failover])

      else return (nl, inst, [])

  -- we now need to execute a replace secondary to the future

  -- primary node

  (nl2, inst2, _, _) <-

    opToResult $

    applyMove nl1 inst1 o1

  let ops2 = o1:ops1

  -- we now execute another failover, the primary stays fixed now

                        opToResult $ applyMove nl2 inst2 o2

  let ops3 = o2:ops2

  -- and finally another replace secondary, to the final secondary

  (nl4, inst4, _, _) <-

    opToResult $

    applyMove nl3 inst3 o3

  let ops4 = o3:ops3

-- | Error beautifier.

wrapIO :: IO (Result a) -> IO (Result a)

-- | Parses a user-supplied utilisation string.

parseUtilisation :: String -> Result (String, DynUtil)

  input_data <-

    case () of

      _ | setRapi -> wrapIO $ Rapi.loadData mhost

        | setSim -> Simu.loadData simdata

        | otherwise -> return $ Bad "No backend selected! Exiting."

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

      MirrorNone -> fail "Can't relocate non-mirrored instances"

      MirrorInternal -> return (sorig, "secondary", ChangeSecondary)

      MirrorExternal -> return (porig, "primary", ChangePrimary)

       -- FIXME: we can't use the excluded nodes here; the logic is

       -- already _but only partially_ implemented in tryNodeEvac...

       fail $ "Unsupported request: excluded nodes not equal to\

  let Request rq cdata = request

       hPutStrLn stderr $ "Received request: " ++ show rq

       hPutStrLn stderr $ "Received cluster data: " ++ show cdata

  maybePrintNodes shownodes "Initial cluster"

  -- nothing to do on an empty cluster

  when (Container.null il) $ do

         printf "Cluster is empty, exiting.\n"::IO ()

  -- hbal doesn't currently handle split clusters

  let split_insts = Cluster.findSplitInstances nl il

             "Initial check done: %d bad nodes, %d bad instances.\n"

             (length bad_nodes) (length bad_instances)

         putStrLn "Cluster is not N+1 happy, continuing but no guarantee \

                  \that the cluster will end N+1 happy."

         printf "Cluster is already well balanced (initial score %.6g,\n\

                \minimum score %.6g).\nNothing to do, exiting\n"

                ini_cv min_cv:: IO ()

-- | Main function.

main :: Options -> [String] -> IO ()

  let cmd_jobs = Cluster.splitJobs cmd_strs

       saveBalanceCommands opts $ Cluster.formatCmds cmd_jobs

  maybeSaveData (optSaveCluster opts) "balanced" "after balancing"

  unless (verbose == 0) $ do

    putStrLn ""

    putStr prefix

-- | Extract name or idx from group.

extractGroupData :: Bool -> Group.Group -> String

perGroupChecks gl (gidx, (nl, il)) =

  let grp = Container.find gidx gl

      offnl = filter Node.offline (Container.elems nl)

      conflicttags = length $ filter (>0)

                     (map Node.conflictingPrimaries (Container.elems nl))

      offline_pri = sum . map length $ map Node.pList offnl

  printFinalHTC machineread

      oname = odir </> fixSlash name

  putStrLn $ printCluster nl il

  hFlush stdout

       putStr $ Cluster.printNodes nl (fromJust shownodes)

  writeFile (oname <.> "data") (serializeCluster cdata)

  return True

         let name = local

         input_data <- Luxi.loadData lsock

         result <- writeData nlen name opts input_data

  results <- mapM (\name -> Rapi.loadData name >>= writeData nlen name opts)

             clusters

  case genClusterAlloc count node inst of

    Types.Bad msg -> failTest msg

    Types.Ok (nl, il, inst') ->

                              Cluster.tryNodeEvac defGroupList nl il mode

                                [Instance.idx inst']) .

                              evacModeOptions .

  -- ready

  server <- run $ Luxi.getServer fpath

  -- fork the server responder

    bracket

      (Luxi.acceptClient server)

      (\c -> Luxi.closeClient c >> removeFile fpath)

-- | Helper to convert I/O errors in 'Bad' values.

ioErrToResult :: IO a -> IO (Result a)

ioErrToResult ioaction =

        (\e -> return . Bad . show $ (e::IOException))

-- | Append the default port if not passed in.

readDataFile:: String -- ^ Path to the directory containing the files

             -> IO (Result String, Result String, Result String, Result String)

readDataFile path = do

  return (group_body, node_body, inst_body, info_body)

-- | Loads data via either 'readDataFile' or 'readDataHttp'.

  , parseData

  ) where

import Text.Printf (printf)

import Ganeti.HTools.Utils

parseData :: [String] -- ^ Cluster description in text format

          -> Result ClusterData

parseData ndata = do

  let (groups, nodes) = unzip grpNodeData

      nodes' = concat nodes

  let ktn = map (\(idx, n) -> (idx, Node.setIdx n idx))

loadNode ktg [name, tm, nm, fm, td, fd, tc, fo, gu, spindles] = do

  gdx <- lookupGroup ktg name gu

  new_node <-

          return $ Node.create name 0 0 0 0 0 0 True 0 gdx

      else do

        vtm <- tryRead name tm

  disk_template <- annotateResult ("Instance " ++ name)

                   (diskTemplateFromRaw dt)

  spindle_use <- tryRead name su

           " has same primary and secondary node - " ++ pnode

  let vtags = commaSplit tags

      newinst = Instance.create name vmem vdsk vvcpus vstatus vtags

-- | Constructs a printable table from given header and rows

printTable :: String -> [String] -> [[String]] -> [Bool] -> String

printTable lp header rows isnum =

  formatTable (header:rows) isnum

-- | Converts a unit (e.g. m or GB) into a scaling factor.

-- | Converts a list of bytes to a string.

word8ToString :: HashKey -> String

-- | Computes the HMAC for a given key/test and salt.

computeMac :: HashKey -> Maybe String -> String -> String

                     Just path -> openFormattedHandler file_logging fmt $

                                  fileHandler path level

  updateGlobalLogger rootLoggerName $ setHandlers handlers

  -- syslog handler is special (another type, still instance of the

  -- typeclass, and has a built-in formatter), so we can't pass it in

buildCall :: LuxiOp  -- ^ The method

          -> String  -- ^ The serialized form

buildCall lo =

           ]

      jo = toJSObject ja

  in encodeStrict jo

    "Node " ++ nodeName node ++ " is marked as offline"

rpcErrorJsonReport :: (Monad m) => J.Result a -> m (Either RpcError a)

rpcErrorJsonReport (J.Ok x) = return $ Right x

-- | Basic timeouts for RPC calls.

      url = requestUrl request

  -- FIXME: This is very similar to getUrl in Htools/Rapi.hs

  (code, !body) <- curlGetString url $ curlOpts ++ reqOpts

#endif

-- | Prepare url for the HTTP request.

getPrimaryIPFamily :: Maybe FilePath -> IO (Result Socket.Family)

getPrimaryIPFamily optpath = do

  result <- readSSConfFile optpath (Just (show C.ip4Family)) SSPrimaryIpFamily

          tryRead "Parsing af_family" >>= parseIPFamily)

-- The following two hints warn to simplify e.g. "map (\v -> (v,

-- True)) lst" to "zip lst (repeat True)", which is more abstract

warn = map (\v -> (v, x)) y ==> zip y (repeat x)