Synnefo » snf-ganeti

{-# LANGUAGE TemplateHaskell #-}

{-| Implementation of the Ganeti Unix Domain Socket JSON server interface.

  ) where

import Control.Applicative

import Control.Exception (catch)

import Control.Monad

import qualified Data.ByteString as B

  return Server { sSocket=s, sPath=path, serverConfig=conf }

-- | Closes a server endpoint.

closeServer server =

-- | Accepts a client

acceptClient :: Server -> IO Client

-- | Logs an outgoing message.

logMsg

    :: (Show e, J.JSON e, MonadLog m)

    -> i                          -- ^ the received request (used for logging)

    -> GenericResult e J.JSValue  -- ^ A message to be sent

    -> m ()

-- * Processing client requests

  { hParse         :: J.JSValue -> J.JSValue -> Result i

    -- ^ parses method and its arguments into the input type

  , hInputLogShort :: i -> String

    -- ^ short description of an input, for the INFO logging level

  , hInputLogLong  :: i -> String

    -- ^ long description of an input, for the DEBUG logging level

    -- ^ executes the handler on an input

  }

handleJsonMessage

    -> i                        -- ^ parsed input

handleJsonMessage handler req = do

  (close, call_result) <- hExec handler req

  return (close, fmap J.showJSON call_result)

-- | Takes a request as a 'String', parses it, passes it to a handler and

-- formats its response.

handleRawMessage

    -> String                   -- ^ raw unparsed input

handleRawMessage handler payload =

  case parseCall payload >>= uncurry (hParse handler) of

    Bad err -> do

-- | Reads a request, passes it to a handler and sends a response back to the

-- client.

handleClient

    -> Client

handleClient handler client = do

  when (debugMode && isRisky msg) $

    logAlert "POSSIBLE LEAKING OF CONFIDENTIAL PARAMETERS. \

             \Daemon is running in debug mode. \

                     return False

    RecvOk payload -> do

      (close, outMsg) <- handleRawMessage handler payload

      return close

-- | Main client loop: runs one loop of 'handleClient', and if that

-- doesn't report a finished (closed) connection, restarts itself.

clientLoop

    -> Client

clientLoop handler client = do

  result <- handleClient handler client

  if result

    then clientLoop handler client

-- | Main listener loop: accepts clients, forks an I/O thread to handle

-- that client.

listener

    -> Server

listener handler server = do

  return ()