Synnefo » snf-ganeti » ganeti-local

:set -ihtools -ihtest

# htools-specific rules

/htools/apidoc

/htools/.hpc

/htools/coverage

/htools/mon-collector

/htools/htools

/htools/hconfd

/htools/ganeti-confd

/htools/rpc-test

/htest/hpc-htools

/htest/hpc-mon-collector

/htest/test

/htools/*.prof*

/htools/*.stat

/htools/*.tix

/htest/*.prof*

/htest/*.stat

/htest/*.tix

/.hpc/

/*.tix

/htools/Ganeti/Constants.hs

/htools/Ganeti/Version.hs

	htools \

	htools/Ganeti \

	htools/Ganeti/Block \

	htools/Ganeti/Block/Drbd \

	htools/Ganeti/Confd \

	htools/Ganeti/DataCollectors \

	htools/Ganeti/HTools \

	htools/Ganeti/HTools/Backend \

	htools/Ganeti/HTools/Program \

	htools/Ganeti/Query \

	htools/ganeti-confd \

	.hpc/*.mix htools/*.tix htest/*.tix \

HTOOLS_GENERATED_FILES += htools/hconfd htools/ganeti-confd

HS_PROGS = htools/htools htools/mon-collector

	htools/hconfd \

	htools/rpc-test

	-O -Wall -Werror -ihtools \

	$(patsubst htools.%,--exclude Test.%,$(subst /,.,$(patsubst %.hs,%, $(HS_LIB_SRCS))))

	htools/Ganeti/Block/Drbd/Types.hs \

	htools/Ganeti/Block/Drbd/Parser.hs \

	htools/Ganeti/BasicTypes.hs \

	htools/Ganeti/Common.hs \

	htools/Ganeti/Compat.hs \

	htools/Ganeti/Confd/Client.hs \

	htools/Ganeti/Confd/Server.hs \

	htools/Ganeti/Confd/Types.hs \

	htools/Ganeti/Confd/Utils.hs \

	htools/Ganeti/Config.hs \

	htools/Ganeti/Daemon.hs \

	htools/Ganeti/DataCollectors/CLI.hs \

	htools/Ganeti/DataCollectors/Drbd.hs \

	htools/Ganeti/DataCollectors/Program.hs \

	htools/Ganeti/Errors.hs \

	htools/Ganeti/HTools/Backend/IAlloc.hs \

	htools/Ganeti/HTools/Backend/Luxi.hs \

	htools/Ganeti/HTools/Backend/Rapi.hs \

	htools/Ganeti/HTools/Backend/Simu.hs \

	htools/Ganeti/HTools/Backend/Text.hs \

	htools/Ganeti/HTools/CLI.hs \

	htools/Ganeti/HTools/Cluster.hs \

	htools/Ganeti/HTools/Container.hs \

	htools/Ganeti/HTools/ExtLoader.hs \

	htools/Ganeti/HTools/Graph.hs \

	htools/Ganeti/HTools/Group.hs \

	htools/Ganeti/HTools/Instance.hs \

	htools/Ganeti/HTools/Loader.hs \

	htools/Ganeti/HTools/Node.hs \

	htools/Ganeti/HTools/PeerMap.hs \

	htools/Ganeti/HTools/Program.hs \

	htools/Ganeti/HTools/Program/Hail.hs \

	htools/Ganeti/HTools/Program/Hbal.hs \

	htools/Ganeti/HTools/Program/Hcheck.hs \

	htools/Ganeti/HTools/Program/Hinfo.hs \

	htools/Ganeti/HTools/Program/Hscan.hs \

	htools/Ganeti/HTools/Program/Hspace.hs \

	htools/Ganeti/HTools/Program/Hroller.hs \

	htools/Ganeti/HTools/Types.hs \

	htools/Ganeti/Hash.hs \

	htools/Ganeti/JQueue.hs \

	htools/Ganeti/JSON.hs \

	htools/Ganeti/Jobs.hs \

	htools/Ganeti/Logging.hs \

	htools/Ganeti/Luxi.hs \

	htools/Ganeti/Network.hs \

	htools/Ganeti/Objects.hs \

	htools/Ganeti/OpCodes.hs \

	htools/Ganeti/OpParams.hs \

	htools/Ganeti/Path.hs \

	htools/Ganeti/Query/Common.hs \

	htools/Ganeti/Query/Filter.hs \

	htools/Ganeti/Query/Group.hs \

	htools/Ganeti/Query/Job.hs \

	htools/Ganeti/Query/Language.hs \

	htools/Ganeti/Query/Node.hs \

	htools/Ganeti/Query/Query.hs \

	htools/Ganeti/Query/Server.hs \

	htools/Ganeti/Query/Types.hs \

	htools/Ganeti/Rpc.hs \

	htools/Ganeti/Runtime.hs \

	htools/Ganeti/Ssconf.hs \

	htools/Ganeti/THH.hs \

	htools/Ganeti/Types.hs \

	htools/Ganeti/Utils.hs

	htools/Ganeti/Constants.hs \

	htools/Ganeti/Version.hs

bin_SCRIPTS += $(filter-out htools/hail,$(HS_PROGS))

htools/ganeti-confd: htools/hconfd

nodist_sbin_SCRIPTS += htools/ganeti-confd

	htools/mon-collector

	htools/lint-hints.hs \

htools/Ganeti/Version.hs: htools/Ganeti/Version.hs.in \

htools/Ganeti/Constants.hs: htools/Ganeti/Constants.hs.in \

	  for name in $(filter-out Ganeti.THH,$(subst /,.,$(patsubst %.hs,%,$(patsubst htools/%,%,$(HS_LIB_SRCS))))) ; do \

HLINT_EXCLUDES = htools/Ganeti/THH.hs htest/hpc-htools.hs

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

	  --hint htools/lint-hints \

	cd htools; \

	RELSRCS="$(HS_LIB_SRCS:htools/%=%) $(patsubst htools/%,%,$(filter htools/%,$(HS_BUILT_SRCS)))"; \

	  $(filter-out Ganeti/HTools/ExtLoader.hs,$(HS_LIB_SRCS:htools/%=%))

	cd htools; \

	hpc sum --union $(HPCEXCL) $(addsuffix .tix,$(HS_PROGS:htools/%=%)) \

    cmd = "./htools/htools"

    WriteHaskellCompletion(sw, "htools/ganeti-confd", htools=False,

    WriteHaskellCmdCompletion(sw, "htools/mon-collector", debug=debug)

mkdir -p $tmpdir/htools $tmpdir/htest

  if [ -e htools/$hfile ]; then

    ln -s $PWD/htools/$hfile $tmpdir/htools/

  λ> :l htools/Ganeti/Objects.hs

  $ make htools/htools HEXTRA="-osuf .o"

  $ rm htools/htools

  $ make htools/htools HEXTRA="-osuf .prof_o -prof -auto-all"

../htools/htools.hs

../htools/mon-collector.hs

{-# LANGUAGE FlexibleInstances #-}

{-

Copyright (C) 2009, 2010, 2011, 2012 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 Ganeti.BasicTypes

  ( GenericResult(..)

  , Result

  , ResultT(..)

  , resultT

  , FromString(..)

  , isOk

  , isBad

  , eitherToResult

  , annotateResult

  , select

  , LookupResult(..)

  , MatchPriority(..)

  , lookupName

  , goodLookupResult

  , goodMatchPriority

  , prefixMatch

  , compareNameComponent

  ) where

import Control.Applicative

import Control.Monad

import Control.Monad.Trans

import Data.Function

import Data.List

-- | Generic monad for our error handling mechanisms.

data GenericResult a b

  = Bad a

  | Ok b

    deriving (Show, Eq)

-- | Type alias for a string Result.

type Result = GenericResult String

-- | Type class for things that can be built from strings.

class FromString a where

  mkFromString :: String -> a

-- | Trivial 'String' instance; requires FlexibleInstances extension

-- though.

instance FromString [Char] where

  mkFromString = id

-- | 'Monad' instance for 'GenericResult'.

instance (FromString a) => Monad (GenericResult a) where

  (>>=) (Bad x) _ = Bad x

  (>>=) (Ok x) fn = fn x

  return = Ok

  fail   = Bad . mkFromString

instance Functor (GenericResult a) where

  fmap _ (Bad msg) = Bad msg

  fmap fn (Ok val) = Ok (fn val)

instance MonadPlus (GenericResult String) 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

instance Applicative (GenericResult a) where

  pure = Ok

  (Bad f) <*> _       = Bad f

  _       <*> (Bad x) = Bad x

  (Ok f)  <*> (Ok x)  = Ok $ f x

-- | This is a monad transformation for Result. It's implementation is

-- based on the implementations of MaybeT and ErrorT.

newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)}

instance (Monad m, FromString a) => Monad (ResultT a m) where

  fail err = ResultT (return . Bad $ mkFromString err)

  return   = lift . return

  x >>= f  = ResultT $ do

               a <- runResultT x

               case a of

                 Ok val -> runResultT $ f val

                 Bad err -> return $ Bad err

instance MonadTrans (ResultT a) where

  lift x = ResultT (liftM Ok x)

instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where

  liftIO = lift . liftIO

-- | Lift a `Result` value to a `ResultT`.

resultT :: Monad m => GenericResult a b -> ResultT a m b

resultT = ResultT . return

-- | Simple checker for whether a 'GenericResult' is OK.

isOk :: GenericResult a b -> Bool

isOk (Ok _) = True

isOk _      = False

-- | Simple checker for whether a 'GenericResult' is a failure.

isBad :: GenericResult a b -> Bool

isBad = not . isOk

-- | Converter from Either to 'GenericResult'.

eitherToResult :: Either a b -> GenericResult a b

eitherToResult (Left  s) = Bad s

eitherToResult (Right v) = Ok  v

-- | Annotate a Result with an ownership information.

annotateResult :: String -> Result a -> Result a

annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s

annotateResult _ v = v

-- * Misc functionality

-- | Return the first result with a True condition, or the default otherwise.

select :: a            -- ^ default result

       -> [(Bool, a)]  -- ^ list of \"condition, result\"

       -> a            -- ^ first result which has a True condition, or default

select def = maybe def snd . find fst

-- * Lookup of partial names functionality

-- | The priority of a match in a lookup result.

data MatchPriority = ExactMatch

                   | MultipleMatch

                   | PartialMatch

                   | FailMatch

                   deriving (Show, Enum, Eq, Ord)

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

-- | Lookup results have an absolute preference ordering.

instance Eq LookupResult where

  (==) = (==) `on` lrMatchPriority

instance Ord LookupResult where

  compare = compare `on` lrMatchPriority

-- | Check for prefix matches in names.

-- Implemented in Ganeti core utils.text.MatchNameComponent

-- as the regexp r"^%s(\..*)?$" % re.escape(key)

prefixMatch :: String  -- ^ Lookup

            -> String  -- ^ Full name

            -> Bool    -- ^ Whether there is a prefix match

prefixMatch = isPrefixOf . (++ ".")

-- | Is the lookup priority a "good" one?

goodMatchPriority :: MatchPriority -> Bool

goodMatchPriority ExactMatch = True

goodMatchPriority PartialMatch = True

goodMatchPriority _ = False

-- | Is the lookup result an actual match?

goodLookupResult :: LookupResult -> Bool

goodLookupResult = goodMatchPriority . lrMatchPriority

-- | Compares a canonical name and a lookup string.

compareNameComponent :: String        -- ^ Canonical (target) name

                     -> String        -- ^ Partial (lookup) name

                     -> LookupResult  -- ^ Result of the lookup

compareNameComponent cnl lkp =

  select (LookupResult FailMatch lkp)

  [ (cnl == lkp          , LookupResult ExactMatch cnl)

  , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)

  ]

-- | Lookup a string and choose the best result.

chooseLookupResult :: String       -- ^ Lookup key

                   -> String       -- ^ String to compare to the lookup key

                   -> LookupResult -- ^ Previous result

                   -> LookupResult -- ^ New result

chooseLookupResult lkp cstr old =

  -- default: use class order to pick the minimum result

  select (min new old)

  -- special cases:

  -- short circuit if the new result is an exact match

  [ (lrMatchPriority new == ExactMatch, new)

  -- if both are partial matches generate a multiple match

  , (partial2, LookupResult MultipleMatch lkp)

  ] where new = compareNameComponent cstr lkp

          partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]

-- | Find the canonical name for a lookup string in a list of names.

lookupName :: [String]      -- ^ List of keys

           -> String        -- ^ Lookup string

           -> LookupResult  -- ^ Result of the lookup

lookupName l s = foldr (chooseLookupResult s)

                       (LookupResult FailMatch s) l

{-# LANGUAGE OverloadedStrings #-}

{-| DRBD proc file parser

This module holds the definition of the parser that extracts status

information from the DRBD proc file.

-}

{-

Copyright (C) 2012 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 Ganeti.Block.Drbd.Parser (drbdStatusParser, commaIntParser) where

import Control.Applicative ((<*>), (*>), (<*), (<$>), (<|>), pure)

import qualified Data.Attoparsec.Text as A

import qualified Data.Attoparsec.Combinator as AC

import Data.Attoparsec.Text (Parser)

import Data.Maybe

import Data.Text (Text, unpack)

import Ganeti.Block.Drbd.Types

-- | Our own space-skipping function, because A.skipSpace also skips

-- newline characters. It skips ZERO or more spaces, so it does not

-- fail if there are no spaces.

skipSpaces :: Parser ()

skipSpaces = A.skipWhile A.isHorizontalSpace

-- | Skips spaces and the given string, then executes a parser and

-- returns its result.

skipSpacesAndString :: Text -> Parser a -> Parser a

skipSpacesAndString s parser =

  skipSpaces

  *> A.string s

  *> parser

-- | Predicate verifying (potentially bad) end of lines

isBadEndOfLine :: Char -> Bool

isBadEndOfLine c = (c == '\0') || A.isEndOfLine c

-- | Takes a parser and returns it with the content wrapped in a Maybe

-- object. The resulting parser never fails, but contains Nothing if

-- it couldn't properly parse the string.

optional :: Parser a -> Parser (Maybe a)

optional parser = (Just <$> parser) <|> pure Nothing

-- | The parser for a whole DRBD status file.

drbdStatusParser :: Parser DRBDStatus

drbdStatusParser =

  DRBDStatus <$> versionInfoParser

             <*> deviceParser `AC.manyTill` A.endOfInput

             <* A.endOfInput

-- | The parser for the version information lines.

versionInfoParser :: Parser VersionInfo

versionInfoParser = do

  versionF <- optional versionP

  apiF <- optional apiP

  protoF <- optional protoP

  srcVersionF <- optional srcVersion

  ghF <- fmap unpack <$> optional gh

  builderF <- fmap unpack <$> optional builder

  if   isNothing versionF

    && isNothing apiF

    && isNothing protoF

    && isNothing srcVersionF

    && isNothing ghF

    && isNothing builderF

    then fail "versionInfo"

    else pure $ VersionInfo versionF apiF protoF srcVersionF ghF builderF

    where versionP =

            A.string "version:"

            *> skipSpaces

            *> fmap unpack (A.takeWhile $ not . A.isHorizontalSpace)

          apiP =

            skipSpacesAndString "(api:" . fmap unpack $ A.takeWhile (/= '/')

          protoP =

            A.string "/proto:"

            *> fmap Data.Text.unpack (A.takeWhile (/= ')'))

            <* A.takeTill A.isEndOfLine <* A.endOfLine

          srcVersion =

            A.string "srcversion:"

            *> AC.skipMany1 A.space

            *> fmap unpack (A.takeTill A.isEndOfLine)

            <* A.endOfLine

          gh =

            A.string "GIT-hash:"

            *> skipSpaces

            *> A.takeWhile (not . A.isHorizontalSpace)

          builder =

            skipSpacesAndString "build by" $

              skipSpaces

              *> A.takeTill A.isEndOfLine

              <* A.endOfLine

-- | The parser for a (multi-line) string representing a device.

deviceParser :: Parser DeviceInfo

deviceParser = do

  deviceNum <- skipSpaces *> A.decimal <* A.char ':'

  cs <- skipSpacesAndString "cs:" connStateParser

  if cs == Unconfigured

    then do

      _ <- additionalEOL

      return $ UnconfiguredDevice deviceNum

    else do

      ro <- skipSpaces *> skipRoleString *> localRemoteParser roleParser

      ds <- skipSpacesAndString "ds:" $ localRemoteParser diskStateParser

      replicProtocol <- A.space *> A.anyChar

      io <- skipSpaces *> ioFlagsParser <* A.skipWhile isBadEndOfLine

      pIndicators <- perfIndicatorsParser

      syncS <- conditionalSyncStatusParser cs

      reS <- optional resyncParser

      act <- optional actLogParser

      _ <- additionalEOL

      return $ DeviceInfo deviceNum cs ro ds replicProtocol io pIndicators

                          syncS reS act

    where conditionalSyncStatusParser SyncSource = Just <$> syncStatusParser

          conditionalSyncStatusParser SyncTarget = Just <$> syncStatusParser

          conditionalSyncStatusParser _ = pure Nothing

          skipRoleString = A.string "ro:" <|> A.string "st:"

          resyncParser = skipSpacesAndString "resync:" additionalInfoParser

          actLogParser = skipSpacesAndString "act_log:" additionalInfoParser

          additionalEOL = A.skipWhile A.isEndOfLine

-- | The parser for the connection state.

connStateParser :: Parser ConnState

connStateParser =

  standAlone

  <|> disconnecting

  <|> unconnected

  <|> timeout

  <|> brokenPipe

  <|> networkFailure

  <|> protocolError

  <|> tearDown

  <|> wfConnection

  <|> wfReportParams

  <|> connected

  <|> startingSyncS

  <|> startingSyncT

  <|> wfBitMapS

  <|> wfBitMapT

  <|> wfSyncUUID

  <|> syncSource

  <|> syncTarget

  <|> pausedSyncS

  <|> pausedSyncT

  <|> verifyS

  <|> verifyT

  <|> unconfigured

    where standAlone     = A.string "StandAlone"     *> pure StandAlone

          disconnecting  = A.string "Disconnectiog"  *> pure Disconnecting

          unconnected    = A.string "Unconnected"    *> pure Unconnected

          timeout        = A.string "Timeout"        *> pure Timeout

          brokenPipe     = A.string "BrokenPipe"     *> pure BrokenPipe

          networkFailure = A.string "NetworkFailure" *> pure NetworkFailure

          protocolError  = A.string "ProtocolError"  *> pure ProtocolError

          tearDown       = A.string "TearDown"       *> pure TearDown

          wfConnection   = A.string "WFConnection"   *> pure WFConnection

          wfReportParams = A.string "WFReportParams" *> pure WFReportParams

          connected      = A.string "Connected"      *> pure Connected

          startingSyncS  = A.string "StartingSyncS"  *> pure StartingSyncS

          startingSyncT  = A.string "StartingSyncT"  *> pure StartingSyncT

          wfBitMapS      = A.string "WFBitMapS"      *> pure WFBitMapS

          wfBitMapT      = A.string "WFBitMapT"      *> pure WFBitMapT

          wfSyncUUID     = A.string "WFSyncUUID"     *> pure WFSyncUUID

          syncSource     = A.string "SyncSource"     *> pure SyncSource

          syncTarget     = A.string "SyncTarget"     *> pure SyncTarget

          pausedSyncS    = A.string "PausedSyncS"    *> pure PausedSyncS

          pausedSyncT    = A.string "PausedSyncT"    *> pure PausedSyncT

          verifyS        = A.string "VerifyS"        *> pure VerifyS

          verifyT        = A.string "VerifyT"        *> pure VerifyT

          unconfigured   = A.string "Unconfigured"   *> pure Unconfigured

-- | Parser for recognizing strings describing two elements of the

-- same type separated by a '/'. The first one is considered local,

-- the second remote.

localRemoteParser :: Parser a -> Parser (LocalRemote a)

localRemoteParser parser = LocalRemote <$> parser <*> (A.char '/' *> parser)

-- | The parser for resource roles.

roleParser :: Parser Role

roleParser =

  primary

  <|> secondary

  <|> unknown

    where primary   = A.string "Primary"   *> pure Primary

          secondary = A.string "Secondary" *> pure Secondary

          unknown   = A.string "Unknown"   *> pure Unknown

-- | The parser for disk states.

diskStateParser :: Parser DiskState

diskStateParser =

  diskless

  <|> attaching

  <|> failed

  <|> negotiating

  <|> inconsistent

  <|> outdated

  <|> dUnknown

  <|> consistent

  <|> upToDate

    where diskless     = A.string "Diskless"     *> pure Diskless

          attaching    = A.string "Attaching"    *> pure Attaching

          failed       = A.string "Failed"       *> pure Failed

          negotiating  = A.string "Negotiating"  *> pure Negotiating

          inconsistent = A.string "Inconsistent" *> pure Inconsistent

          outdated     = A.string "Outdated"     *> pure Outdated

          dUnknown     = A.string "DUnknown"     *> pure DUnknown

          consistent   = A.string "Consistent"   *> pure Consistent

          upToDate     = A.string "UpToDate"     *> pure UpToDate

-- | The parser for I/O flags.

ioFlagsParser :: Parser String

ioFlagsParser = fmap unpack . A.takeWhile $ not . isBadEndOfLine

-- | The parser for performance indicators.

perfIndicatorsParser :: Parser PerfIndicators

perfIndicatorsParser =

  PerfIndicators

    <$> skipSpacesAndString "ns:" A.decimal

    <*> skipSpacesAndString "nr:" A.decimal

    <*> skipSpacesAndString "dw:" A.decimal

    <*> skipSpacesAndString "dr:" A.decimal

    <*> skipSpacesAndString "al:" A.decimal

    <*> skipSpacesAndString "bm:" A.decimal

    <*> skipSpacesAndString "lo:" A.decimal

    <*> skipSpacesAndString "pe:" A.decimal

    <*> skipSpacesAndString "ua:" A.decimal

    <*> skipSpacesAndString "ap:" A.decimal

    <*> optional (skipSpacesAndString "ep:" A.decimal)

    <*> optional (skipSpacesAndString "wo:" A.anyChar)

    <*> optional (skipSpacesAndString "oos:" A.decimal)

    <* skipSpaces <* A.endOfLine

-- | The parser for the syncronization status.

syncStatusParser :: Parser SyncStatus

syncStatusParser = do

  _ <- statusBarParser

  percent <-

    skipSpacesAndString "sync'ed:" $ skipSpaces *> A.double <* A.char '%'

  partSyncSize <- skipSpaces *> A.char '(' *> A.decimal

  totSyncSize <- A.char '/' *> A.decimal <* A.char ')'

  sizeUnit <- sizeUnitParser <* optional A.endOfLine

  timeToEnd <- skipSpacesAndString "finish:" $ skipSpaces *> timeParser

  sp <-

    skipSpacesAndString "speed:" $

      skipSpaces

      *> commaIntParser

      <* skipSpaces

      <* A.char '('

      <* commaIntParser

      <* A.char ')'

  w <- skipSpacesAndString "want:" (

         skipSpaces

         *> (Just <$> commaIntParser)

       )

       <|> pure Nothing

  sSizeUnit <- skipSpaces *> sizeUnitParser

  sTimeUnit <- A.char '/' *> timeUnitParser

  _ <- A.endOfLine

  return $

    SyncStatus percent partSyncSize totSyncSize sizeUnit timeToEnd sp w

      sSizeUnit sTimeUnit

-- | The parser for recognizing (and discarding) the sync status bar.

statusBarParser :: Parser ()

statusBarParser =

  skipSpaces

  *> A.char '['

  *> A.skipWhile (== '=')

  *> A.skipWhile (== '>')

  *> A.skipWhile (== '.')

  *> A.char ']'

  *> pure ()

-- | The parser for recognizing data size units (only the ones

-- actually found in DRBD files are implemented).

sizeUnitParser :: Parser SizeUnit

sizeUnitParser =

  kilobyte

  <|> megabyte

    where kilobyte = A.string "K" *> pure KiloByte

          megabyte = A.string "M" *> pure MegaByte

-- | The parser for recognizing time (hh:mm:ss).

timeParser :: Parser Time

timeParser = Time <$> h <*> m <*> s

  where h = A.decimal :: Parser Int

        m = A.char ':' *> A.decimal :: Parser Int

        s = A.char ':' *> A.decimal :: Parser Int

-- | The parser for recognizing time units (only the ones actually

-- found in DRBD files are implemented).

timeUnitParser :: Parser TimeUnit

timeUnitParser = second

  where second = A.string "sec" *> pure Second

-- | Haskell does not recognise ',' as the thousands separator every 3

-- digits but DRBD uses it, so we need an ah-hoc parser.

-- If a number beginning with more than 3 digits without a comma is

-- parsed, only the first 3 digits are considered to be valid, the rest

-- is not consumed, and left for further parsing.

commaIntParser :: Parser Int

commaIntParser = do

  first <-

    AC.count 3 A.digit <|> AC.count 2 A.digit <|> AC.count 1 A.digit

  allDigits <- commaIntHelper (read first)

  pure allDigits

-- | Helper (triplet parser) for the commaIntParser

commaIntHelper :: Int -> Parser Int

commaIntHelper acc = nextTriplet <|> end

  where nextTriplet = do

          _ <- A.char ','

          triplet <- AC.count 3 A.digit

          commaIntHelper $ acc * 1000 + (read triplet :: Int)

        end = pure acc :: Parser Int

-- | Parser for the additional information provided by DRBD <= 8.0.

additionalInfoParser::Parser AdditionalInfo

additionalInfoParser = AdditionalInfo

  <$> skipSpacesAndString "used:" A.decimal

  <*> (A.char '/' *> A.decimal)

  <*> skipSpacesAndString "hits:" A.decimal

  <*> skipSpacesAndString "misses:" A.decimal

  <*> skipSpacesAndString "starving:" A.decimal

  <*> skipSpacesAndString "dirty:" A.decimal

  <*> skipSpacesAndString "changed:" A.decimal

  <* A.endOfLine

{-| DRBD Data Types

This module holds the definition of the data types describing the status of

DRBD.

-}

{-

Copyright (C) 2012 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 Ganeti.Block.Drbd.Types

  ( DRBDStatus(..)

  , VersionInfo(..)

  , DeviceInfo(..)

  , ConnState(..)

  , LocalRemote(..)

  , Role(..)

  , DiskState(..)

  , PerfIndicators(..)

  , SyncStatus(..)

  , SizeUnit(..)

  , Time(..)

  , TimeUnit(..)

  , AdditionalInfo(..)

  ) where

import Text.JSON

import Text.Printf

import Ganeti.JSON

--TODO: consider turning deviceInfos into an IntMap

-- | Data type contaning all the data about the status of DRBD.

data DRBDStatus =

  DRBDStatus

  { versionInfo :: VersionInfo  -- ^ Version information about DRBD

  , deviceInfos :: [DeviceInfo] -- ^ Per-minor information

  } deriving (Eq, Show)

-- | The DRBDStatus instance of JSON.

instance JSON DRBDStatus where

  showJSON d = makeObj

    [ ("versionInfo", showJSON $ versionInfo d)

    , ("deviceInfos", showJSONs $ deviceInfos d)

    ]

  readJSON = error "JSON read instance not implemented for type DRBDStatus"

-- | Data type describing the DRBD version.

data VersionInfo =

  VersionInfo

  { version    :: Maybe String -- ^ DRBD driver version

  , api        :: Maybe String -- ^ The api version

  , proto      :: Maybe String -- ^ The protocol version

  , srcversion :: Maybe String -- ^ The version of the source files

  , gitHash    :: Maybe String -- ^ Git hash of the source files

  , buildBy    :: Maybe String -- ^ Who built the binary (and,

                               -- optionally, when)

  } deriving (Eq, Show)

-- | The VersionInfo instance of JSON.

instance JSON VersionInfo where

  showJSON (VersionInfo versionF apiF protoF srcversionF gitHashF buildByF) =

    optFieldsToObj

      [ optionalJSField "version" versionF

      , optionalJSField "api" apiF

      , optionalJSField "proto" protoF

      , optionalJSField "srcversion" srcversionF

      , optionalJSField "gitHash" gitHashF

      , optionalJSField "buildBy" buildByF

      ]

  readJSON = error "JSON read instance not implemented for type VersionInfo"

-- | Data type describing a device.

data DeviceInfo =

  UnconfiguredDevice Int -- ^ An DRBD minor marked as unconfigured

  | -- | A configured DRBD minor

    DeviceInfo

      { minorNumber :: Int -- ^ The minor index of the device

      , connectionState :: ConnState -- ^ State of the connection

      , resourceRoles :: LocalRemote Role -- ^ Roles of the resources

      , diskStates :: LocalRemote DiskState -- ^ Status of the disks

      , replicationProtocol :: Char -- ^ The replication protocol being used

      , ioFlags :: String -- ^ The input/output flags

      , perfIndicators

          :: PerfIndicators -- ^ Performance indicators

      , syncStatus :: Maybe SyncStatus -- ^ The status of the syncronization of

                                       -- the disk (only if it is happening)

      , resync :: Maybe AdditionalInfo -- ^ Additional info by DRBD 8.0

      , actLog :: Maybe AdditionalInfo -- ^ Additional info by DRBD 8.0

      } deriving (Eq, Show)

-- | The DeviceInfo instance of JSON.

instance JSON DeviceInfo where

  showJSON (UnconfiguredDevice num) = makeObj

    [ ("minor", showJSON num)

    , ("connectionState", showJSON Unconfigured)

    ]

  showJSON (DeviceInfo minorNumberF connectionStateF (LocalRemote

    localRole remoteRole) (LocalRemote localState remoteState)

    replicProtocolF ioFlagsF perfIndicatorsF syncStatusF _ _) =

    optFieldsToObj

    [ Just ("minor", showJSON minorNumberF)

    , Just ("connectionState", showJSON connectionStateF)

    , Just ("localRole", showJSON localRole)

    , Just ("remoteRole", showJSON remoteRole)

    , Just ("localState", showJSON localState)

    , Just ("remoteState", showJSON remoteState)

    , Just ("replicationProtocol", showJSON replicProtocolF)

    , Just ("ioFlags", showJSON ioFlagsF)

    , Just ("perfIndicators", showJSON perfIndicatorsF)

    , optionalJSField "syncStatus" syncStatusF

    ]

  readJSON = error "JSON read instance not implemented for type DeviceInfo"

-- | Data type describing the state of the connection.

data ConnState

  = StandAlone     -- ^  No network configuration available

  | Disconnecting  -- ^ Temporary state during disconnection

  | Unconnected    -- ^ Prior to a connection attempt

  | Timeout        -- ^ Following a timeout in the communication

  | BrokenPipe     -- ^ After the connection to the peer was lost

  | NetworkFailure -- ^ After the connection to the parner was lost

  | ProtocolError  -- ^ After the connection to the parner was lost

  | TearDown       -- ^ The peer is closing the connection

  | WFConnection   -- ^ Waiting for the peer to become visible

  | WFReportParams -- ^ Waiting for first packet from peer

  | Connected      -- ^ Connected, data mirroring active

  | StartingSyncS  -- ^ Source of a full sync started by admin

  | StartingSyncT  -- ^ Target of a full sync started by admin

  | WFBitMapS      -- ^ Source of a just starting partial sync

  | WFBitMapT      -- ^ Target of a just starting partial sync

  | WFSyncUUID     -- ^ Synchronization is about to begin

  | SyncSource     -- ^ Source of a running synchronization

  | SyncTarget     -- ^ Target of a running synchronization

  | PausedSyncS    -- ^ Source of a paused synchronization

  | PausedSyncT    -- ^ Target of a paused synchronization

  | VerifyS        -- ^ Source of an running verification

  | VerifyT        -- ^ Target of an running verification

  | Unconfigured   -- ^ The device is not configured

    deriving (Show, Eq)

-- | The ConnState instance of JSON.

instance JSON ConnState where

  showJSON = showJSON . show

  readJSON = error "JSON read instance not implemented for type ConnState"

-- | Algebraic data type describing something that has a local and a remote

-- value.

data LocalRemote a =

  LocalRemote

  { local  :: a -- ^ The local value

  , remote :: a -- ^ The remote value

  } deriving (Eq, Show)

-- | Data type describing.

data Role = Primary   -- ^ The device role is primary

          | Secondary -- ^ The device role is secondary

          | Unknown   -- ^ The device role is unknown

            deriving (Eq, Show)

-- | The Role instance of JSON.

instance JSON Role where

  showJSON = showJSON . show

  readJSON = error "JSON read instance not implemented for type Role"

-- | Data type describing disk states.

data DiskState

  = Diskless     -- ^ No local block device assigned to the DRBD driver

  | Attaching    -- ^ Reading meta data

  | Failed       -- ^ I/O failure

  | Negotiating  -- ^ "Attach" on an already-connected device

  | Inconsistent -- ^ The data is inconsistent between nodes.

  | Outdated     -- ^ Data consistent but outdated

  | DUnknown     -- ^ No network connection available

  | Consistent   -- ^ Consistent data, but without network connection

  | UpToDate     -- ^ Consistent, up-to-date. This is the normal state

    deriving (Eq, Show)

-- | The DiskState instance of JSON.

instance JSON DiskState where

  showJSON = showJSON . show

  readJSON = error "JSON read instance not implemented for type DiskState"

-- | Data type containing data about performance indicators.

data PerfIndicators = PerfIndicators

  { networkSend :: Int -- ^ KiB of data sent on the network

  , networkReceive :: Int -- ^ KiB of data received from the network

  , diskWrite :: Int -- ^ KiB of data written on local disk

  , diskRead :: Int -- ^ KiB of data read from local disk

  , activityLog :: Int -- ^ Number of updates of the activity log

  , bitMap :: Int -- ^ Number of updates to the bitmap area of the metadata

  , localCount :: Int -- ^ Number of open requests to te local I/O subsystem

  , pending :: Int -- ^ Num of requests sent to the partner but not yet answered

  , unacknowledged :: Int -- ^ Num of requests received by the partner but still

                        -- to be answered

  , applicationPending :: Int -- ^ Num of block I/O requests forwarded

                              -- to DRBD but that have not yet been

                              -- answered

  , epochs :: Maybe Int -- ^ Number of epoch objects

  , writeOrder :: Maybe Char -- ^ Currently used write ordering method

  , outOfSync :: Maybe Int -- ^ KiB of storage currently out of sync

  } deriving (Eq, Show)

-- | The PerfIndicators instance of JSON.

instance JSON PerfIndicators where

  showJSON p = optFieldsToObj

    [ Just ("networkSend", showJSON $ networkSend p)

    , Just ("networkReceive", showJSON $ networkReceive p)

    , Just ("diskWrite", showJSON $ diskWrite p)

    , Just ("diskRead", showJSON $ diskRead p)

    , Just ("activityLog", showJSON $ activityLog p)

    , Just ("bitMap", showJSON $ bitMap p)

    , Just ("localCount", showJSON $ localCount p)

    , Just ("pending", showJSON $ pending p)

    , Just ("unacknowledged", showJSON $ unacknowledged p)

    , Just ("applicationPending", showJSON $ applicationPending p)

    , optionalJSField "epochs" $ epochs p

    , optionalJSField "writeOrder" $ writeOrder p

    , optionalJSField "outOfSync" $ outOfSync p

    ]

  readJSON = error "JSON read instance not implemented for type PerfIndicators"

-- | Data type containing data about the synchronization status of a device.

data SyncStatus =

  SyncStatus

  { percentage      :: Double    -- ^ Percentage of syncronized data

  , partialSyncSize :: Int       -- ^ Numerator of the fraction of synced data

  , totalSyncSize   :: Int       -- ^ Denominator of the fraction of

                                 -- synced data

  , syncUnit        :: SizeUnit  -- ^ Measurement unit of the previous

                                 -- fraction

  , timeToFinish    :: Time      -- ^ Expected time before finishing

                                 -- the syncronization

  , speed           :: Int       -- ^ Speed of the syncronization

  , want            :: Maybe Int -- ^ Want of the syncronization

  , speedSizeUnit   :: SizeUnit  -- ^ Size unit of the speed

  , speedTimeUnit   :: TimeUnit  -- ^ Time unit of the speed

  } deriving (Eq, Show)

-- | The SyncStatus instance of JSON.

instance JSON SyncStatus where

  showJSON s = optFieldsToObj

    [ Just ("percentage", showJSON $ percentage s)

    , Just ("progress", showJSON $ show (partialSyncSize s) ++ "/" ++

        show (totalSyncSize s))

    , Just ("progressUnit", showJSON $ syncUnit s)

    , Just ("timeToFinish", showJSON $ timeToFinish s)

    , Just ("speed", showJSON $ speed s)

    , optionalJSField "want" $ want s

    , Just ("speedUnit", showJSON $ show (speedSizeUnit s) ++ "/" ++

        show (speedTimeUnit s))

    ]

  readJSON = error "JSON read instance not implemented for type SyncStatus"

-- | Data type describing a size unit for memory.

data SizeUnit = KiloByte | MegaByte deriving (Eq, Show)

-- | The SizeUnit instance of JSON.

instance JSON SizeUnit where

  showJSON = showJSON . show

  readJSON = error "JSON read instance not implemented for type SizeUnit"

-- | Data type describing a time (hh:mm:ss).

data Time = Time

  { hour :: Int

  , min  :: Int

  , sec  :: Int

  } deriving (Eq, Show)

-- | The Time instance of JSON.

instance JSON Time where

  showJSON (Time h m s) = showJSON (printf "%02d:%02d:%02d" h m s :: String)

  readJSON = error "JSON read instance not implemented for type Time"

-- | Data type describing a time unit.

data TimeUnit = Second deriving (Eq, Show)

-- | The TimeUnit instance of JSON.

instance JSON TimeUnit where

  showJSON Second = showJSON "Second"

  readJSON = error "JSON read instance not implemented for type TimeUnit"

-- | Additional device-specific cache-like information produced by

-- drbd <= 8.0.

--

-- Internal debug information exported by old DRBD versions.

-- Undocumented both in DRBD and here.

data AdditionalInfo = AdditionalInfo

  { partialUsed :: Int

  , totalUsed   :: Int

  , hits        :: Int

  , misses      :: Int

  , starving    :: Int

  , dirty       :: Int

  , changed     :: Int

  } deriving (Eq, Show)

{-| Base common functionality.

This module holds common functionality shared across Ganeti daemons,

HTools and any other programs.

-}

{-

Copyright (C) 2009, 2010, 2011, 2012 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 Ganeti.Common

  ( GenericOptType

  , StandardOptions(..)

  , OptCompletion(..)

  , ArgCompletion(..)

  , PersonalityList

  , optComplYesNo

  , oShowHelp

  , oShowVer

  , oShowComp

  , usageHelp

  , versionInfo

  , formatCommands

  , reqWithConversion

  , parseYesNo

  , parseOpts

  , parseOptsInner

  , parseOptsCmds

  , genericMainCmds

  ) where

import Control.Monad (foldM)

import Data.Char (toLower)

import Data.List (intercalate, stripPrefix, sortBy)

import Data.Maybe (fromMaybe)

import Data.Ord (comparing)

import qualified Data.Version

import System.Console.GetOpt

import System.Environment

import System.Exit

import System.Info