Revision 0aff2293

b/htools/Ganeti/Luxi.hs
32 32 
  , LuxiReq(..)
33 33 
  , Client
34 34 
  , JobId
35 
  , RecvResult(..)
36 
  , strOfOp
35 37 
  , checkRS
36 38 
  , getClient
37 39 
  , getServer
38 40 
  , acceptClient
39 41 
  , closeClient
42 
  , closeServer
40 43 
  , callMethod
41 44 
  , submitManyJobs
42 45 
  , queryJobsStatus
43 46 
  , buildCall
47 
  , buildResponse
44 48 
  , validateCall
45 49 
  , decodeCall
46 50 
  , recvMsg
51 
  , recvMsgExt
47 52 
  , sendMsg
48 53 
  ) where
49 54 

  		





  
  55
  
    
import Control.Exception (catch)


  		





  50
  56
  
    
import Data.IORef


  		





  51
  57
  
    
import Data.Ratio (numerator, denominator)


  		





  52
  58
  
    
import qualified Data.ByteString as B


  		





  53
  59
  
    
import qualified Data.ByteString.UTF8 as UTF8


  		





  54
  60
  
    
import Data.Word (Word8)


  		





  55
  61
  
    
import Control.Monad


  		





  
  62
  
    
import Prelude hiding (catch)


  		





  56
  63
  
    
import Text.JSON (encodeStrict, decodeStrict)


  		





  57
  64
  
    
import qualified Text.JSON as J


  		





  58
  65
  
    
import Text.JSON.Types


  		





  
  66
  
    
import System.Directory (removeFile)


  		





  59
  67
  
    
import System.IO (hClose, hFlush, hWaitForInput, Handle, IOMode(..))


  		





  
  68
  
    
import System.IO.Error (isEOFError)


  		





  60
  69
  
    
import System.Timeout


  		





  61
  70
  
    
import qualified Network.Socket as S


  		





  62
  71
  
    

  		





  ......




  81
  90
  
    

  		





  82
  91
  
    
-- * Generic protocol functionality


  		





  83
  92
  
    

  		





  
  93
  
    
-- | Result of receiving a message from the socket.


  		





  
  94
  
    
data RecvResult = RecvConnClosed    -- ^ Connection closed


  		





  
  95
  
    
                | RecvError String  -- ^ Any other error


  		





  
  96
  
    
                | RecvOk String     -- ^ Successfull receive


  		





  
  97
  
    
                  deriving (Show, Read, Eq)


  		





  
  98
  
    

  		





  84
  99
  
    
-- | The Ganeti job type.


  		





  85
  100
  
    
type JobId = Int


  		





  86
  101
  
    

  		





  ......




  228
  243
  
    
  S.listen s 5 -- 5 is the max backlog


  		





  229
  244
  
    
  return s


  		





  230
  245
  
    

  		





  
  246
  
    
-- | Closes a server endpoint.


  		





  
  247
  
    
-- FIXME: this should be encapsulated into a nicer type.


  		





  
  248
  
    
closeServer :: FilePath -> S.Socket -> IO ()


  		





  
  249
  
    
closeServer path sock = do


  		





  
  250
  
    
  S.sClose sock


  		





  
  251
  
    
  removeFile path


  		





  
  252
  
    

  		





  231
  253
  
    
-- | Accepts a client


  		





  232
  254
  
    
acceptClient :: S.Socket -> IO Client


  		





  233
  255
  
    
acceptClient s = do


  		





  ......




  276
  298
  
    
  writeIORef (rbuf s) nbuf


  		





  277
  299
  
    
  return $ UTF8.toString msg


  		





  278
  300
  
    

  		





  
  301
  
    
-- | Extended wrapper over recvMsg.


  		





  
  302
  
    
recvMsgExt :: Client -> IO RecvResult


  		





  
  303
  
    
recvMsgExt s =


  		





  
  304
  
    
  catch (liftM RecvOk (recvMsg s)) $ \e ->


  		





  
  305
  
    
    if isEOFError e


  		





  
  306
  
    
      then return RecvConnClosed


  		





  
  307
  
    
      else return $ RecvError (show e)


  		





  
  308
  
    

  		





  279
  309
  
    
-- | Serialize a request to String.


  		





  280
  310
  
    
buildCall :: LuxiOp  -- ^ The method


  		





  281
  311
  
    
          -> String  -- ^ The serialized form


  		





  ......




  286
  316
  
    
      jo = toJSObject ja


  		





  287
  317
  
    
  in encodeStrict jo


  		





  288
  318
  
    

  		





  
  319
  
    
-- | Serialize the response to String.


  		





  
  320
  
    
buildResponse :: Bool    -- ^ Success


  		





  
  321
  
    
              -> JSValue -- ^ The arguments


  		





  
  322
  
    
              -> String  -- ^ The serialized form


  		





  
  323
  
    
buildResponse success args =


  		





  
  324
  
    
  let ja = [ (strOfKey Success, JSBool success)


  		





  
  325
  
    
           , (strOfKey Result, args)]


  		





  
  326
  
    
      jo = toJSObject ja


  		





  
  327
  
    
  in encodeStrict jo


  		





  
  328
  
    

  		





  289
  329
  
    
-- | Check that luxi request contains the required keys and parse it.


  		





  290
  330
  
    
validateCall :: String -> Result LuxiCall


  		





  291
  331
  
    
validateCall s = do


  		





  292
  
  
    
  arr <- fromJResult "luxi call" $ decodeStrict s::Result (JSObject JSValue)


  		





  
  332
  
    
  arr <- fromJResult "parsing top-level luxi message" $


  		





  
  333
  
    
         decodeStrict s::Result (JSObject JSValue)


  		





  293
  334
  
    
  let aobj = fromJSObject arr


  		





  294
  335
  
    
  call <- fromObj aobj (strOfKey Method)::Result LuxiReq


  		





  295
  336
  
    
  args <- fromObj aobj (strOfKey Args)


  		












Also available in:
  Unified diff