Synnefo » snf-ganeti » ganeti-local

  `utf8-string <http://hackage.haskell.org/package/utf8-string>`_

  libraries; these usually come with the GHC compiler

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

Some of these are also available as package in Debian/Ubuntu::

  $ apt-get install ghc6 libghc6-json-dev libghc6-network-dev \

Or in newer versions of these distributions (using GHC 7.x)::

  $ apt-get install ghc libghc-json-dev libghc-network-dev \

  $ yum install ghc ghc-json-devel ghc-network-devel \

                    ghc-parallel-devel ghc-deepseq-devel

Then install the additional libraries via

``cabal``::

Haskell optional features

~~~~~~~~~~~~~~~~~~~~~~~~~

Optionally, more functionality can be enabled if your build machine has

(``--enable-monitoring``). The list of extra dependencies for these is:

- `hslogger <http://software.complete.org/hslogger>`_, version 1.1 and

  above (note that Debian Squeeze only has version 1.0.9)

- `Crypto <http://hackage.haskell.org/package/Crypto>`_, tested with

the exception of curl), so you can use either apt::

  $ apt-get install libghc-hslogger-dev libghc-crypto-dev libghc-text-dev \

                    libghc-attoparsec-dev libghc-vector-dev

or ``cabal``::

                  attoparsec vector

to install them.

  $ yum install ghc-hslogger-devel ghc-text-devel \

                ghc-regex-pcre-devel

	@rm -f $(notdir $@).tix

	$(GHC) --make \

	  $(HFLAGS) \

	  -osuf $(notdir $@).o -hisuf $(notdir $@).hi \

	  $(HEXTRA) $(HEXTRA_INT) $@

	@touch "$@"

	$(LN_S) ../hscolour.css $(APIDOC_HS_DIR)/Ganeti/Confd/hscolour.css

	set -e ; \

	cd src; \

	if [ "$(HS_PARALLEL3)" ]; \

	then OPTGHC="$$OPTGHC --optghc=$(HS_PARALLEL3)"; \

	fi; \

	rm -f TAGS

	$(GHC) -e ":etags" -v0 \

	  $(filter-out -O -Werror,$(HFLAGS)) \

	  $(HS_LIBTEST_SRCS)

	find . -path './lib/*.py' -o -path './scripts/gnt-*' -o \

	  -path './daemons/ganeti-*' -o -path './tools/*' -o \

  AC_MSG_WARN([qemu-img not found, using ovfconverter will not be possible])

fi

# --enable-confd

ENABLE_CONFD=

AC_ARG_ENABLE([confd],

# check for modules, first custom/special checks

AC_MSG_NOTICE([checking for required haskell modules])

HS_PARALLEL3=

AC_GHC_PKG_CHECK([parallel-3.*], [HS_PARALLEL3=-DPARALLEL3],

                 [AC_GHC_PKG_REQUIRE(parallel)], t)

AC_SUBST(HS_PARALLEL3)

# and now standard modules

AC_GHC_PKG_REQUIRE(json)

AC_GHC_PKG_REQUIRE(network)

AC_GHC_PKG_REQUIRE(mtl)

        ;;

    esac

  ]],

       enable_split_query=True

       ;;

     *)

  AC_MSG_ERROR([Split queries require the confd daemon])

fi

if test x$enable_split_query = xTrue; then

  AC_MSG_NOTICE([Split query functionality enabled])

fi

import Control.Exception

import Data.List (isPrefixOf)

import Data.Maybe (fromMaybe)

import Network.Curl

import Network.Curl.Types ()

import Control.Monad

import Text.JSON (JSObject, fromJSObject, decodeStrict)

import Text.JSON.Types (JSValue(..))

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

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

-- | Connection timeout (when using non-file methods).

connTimeout :: Long

connTimeout = 15

            CurlOK -> return body

            _ -> fail $ printf "Curl error for '%s', error %s"

                 url (show code))

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

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

  BangPatterns, TemplateHaskell #-}

{-| Implementation of the RPC client.

{-

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

import qualified Text.JSON as J

import Text.JSON.Pretty (pp_value)

import Network.Curl

import qualified Ganeti.Path as P

import qualified Ganeti.Constants as C

import Ganeti.Objects

-- * Base RPC functionality and types

-- | The curl options used for RPC.

curlOpts :: [CurlOption]

curlOpts = [ CurlFollowLocation False

           , CurlSSLKeyType "PEM"

           , CurlConnectTimeout (fromIntegral C.rpcConnectTimeout)

           ]

-- | Data type for RPC error reporting.

data RpcError

  | JsonDecodeError String

  | RpcResultError String

  | OfflineNodeError Node

-- | Provide explanation to RPC errors.

explainRpcError :: RpcError -> String

explainRpcError (CurlLayerError node code) =

    "Curl error for " ++ nodeName node ++ ", " ++ code

explainRpcError (JsonDecodeError msg) =

                   -> IO (ERpcError String)

executeHttpRequest _ (Left rpc_err) = return $ Left rpc_err

executeHttpRequest node (Right request) = do

  cert_file <- P.nodedCertFile

  let reqOpts = [ CurlTimeout (fromIntegral $ requestTimeout request)

  return $ case code of

             CurlOK -> Right body

             _ -> Left $ CurlLayerError node (show code)

-- | Prepare url for the HTTP request.

prepareUrl :: (RpcCall a) => Node -> a -> String