Synnefo » snf-ganeti

{-| Solver for N+1 cluster errors

-}

{-

Copyright (C) 2009 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

the Free Software Foundation; either version 2 of the License, or

(at your option) any later version.

This program is distributed in the hope that it will be useful, but

WITHOUT ANY WARRANTY; without even the implied warranty of

MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

General Public License for more details.

You should have received a copy of the GNU General Public License

along with this program; if not, write to the Free Software

Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA

02110-1301, USA.

-}

module Main (main) where

import Data.List

import Data.Function

import Data.Maybe (isJust, fromJust)

import Monad

import System

import System.IO

import qualified System

import Text.Printf (printf)

import qualified Ganeti.HTools.Cluster as Cluster

import qualified Ganeti.HTools.Node as Node

import Ganeti.HTools.CLI

import Ganeti.HTools.IAlloc

import Ganeti.HTools.Types

import Ganeti.HTools.Loader (RqType(..), Request(..))

-- | Options list and functions

options :: [OptType]

options = [oPrintNodes, oShowVer, oShowHelp]

processResults :: (Monad m) => Cluster.AllocSolution -> m (String, [Node.Node])

processResults (fstats, successes, sols) =

    case sols of

      Nothing -> fail "No valid allocation solutions"

      Just (best, (_, _, w)) ->

          let tfails = length fstats

              info = printf "successes %d, failures %d,\

                            \ best score: %.8f for node(s) %s"

                            successes tfails

                            best (intercalate "/" . map Node.name $ w)::String

          in return (info, w)

-- | Process a request and return new node lists

processRequest :: Request

               -> Result Cluster.AllocSolution

processRequest request =

  let Request rqtype nl il _ _ = request

  in case rqtype of

       Allocate xi reqn -> Cluster.tryAlloc nl il xi reqn

       Relocate idx reqn exnodes -> Cluster.tryReloc nl il idx reqn exnodes

-- | Main function.

main :: IO ()

main = do

  cmd_args <- System.getArgs

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

  when (null args) $ do

         hPutStrLn stderr "Error: this program needs an input file."

         exitWith $ ExitFailure 1

  let input_file = head args

      shownodes = optShowNodes opts

  input_data <- readFile input_file

  request <- case (parseData input_data) of

               Bad err -> do

                 hPutStrLn stderr $ "Error: " ++ err

                 exitWith $ ExitFailure 1

               Ok rq -> return rq

  let Request _ nl _ _ csf = request

  when (isJust shownodes) $ do

         hPutStrLn stderr "Initial cluster status:"

         hPutStrLn stderr $ Cluster.printNodes nl (fromJust shownodes)

  let sols = processRequest request >>= processResults

  let (ok, info, rn) =

          case sols of

            Ok (ginfo, sn) -> (True, "Request successful: " ++ ginfo,

                                   map ((++ csf) . Node.name) sn)

            Bad s -> (False, "Request failed: " ++ s, [])

      resp = formatResponse ok info rn

  putStrLn resp