Revision 9188aeef Ganeti/HTools/IAlloc.hs

b/Ganeti/HTools/IAlloc.hs
11 11 
    ) where
12 12 

  		





  13
  13
  
    
import Data.Either ()


  		





  14
  
  
    
--import Data.Maybe


  		





  15
  14
  
    
import Control.Monad


  		





  16
  15
  
    
import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),


  		





  17
  16
  
    
                  makeObj, encodeStrict, decodeStrict,


  		





  18
  17
  
    
                  fromJSObject, toJSString)


  		





  19
  
  
    
--import Text.Printf (printf)


  		





  20
  18
  
    
import qualified Ganeti.HTools.Container as Container


  		





  21
  19
  
    
import qualified Ganeti.HTools.Node as Node


  		





  22
  20
  
    
import qualified Ganeti.HTools.Instance as Instance


  		





  ......




  24
  22
  
    
import Ganeti.HTools.Utils


  		





  25
  23
  
    
import Ganeti.HTools.Types


  		





  26
  24
  
    

  		





  
  25
  
    
-- | The request type.


  		





  27
  26
  
    
data RqType


  		





  28
  
  
    
    = Allocate Instance.Instance Int


  		





  29
  
  
    
    | Relocate Idx Int [Ndx]


  		





  
  27
  
    
    = Allocate Instance.Instance Int -- ^ A new instance allocation


  		





  
  28
  
    
    | Relocate Idx Int [Ndx]         -- ^ Move an instance to a new


  		





  
  29
  
    
                                     -- secondary node


  		





  30
  30
  
    
    deriving (Show)


  		





  31
  31
  
    

  		





  
  32
  
    
-- | A complete request, as received from Ganeti.


  		





  32
  33
  
    
data Request = Request RqType Node.List Instance.List String


  		





  33
  34
  
    
    deriving (Show)


  		





  34
  35
  
    

  		





  
  36
  
    
-- | Parse the basic specifications of an instance.


  		





  
  37
  
    
--


  		





  
  38
  
    
-- Instances in the cluster instance list and the instance in an


  		





  
  39
  
    
-- 'Allocate' request share some common properties, which are read by


  		





  
  40
  
    
-- this function.


  		





  35
  41
  
    
parseBaseInstance :: String


  		





  36
  42
  
    
                  -> JSObject JSValue


  		





  37
  43
  
    
                  -> Result (String, Instance.Instance)


  		





  ......




  48
  54
  
    
  let running = "running"


  		





  49
  55
  
    
  return $ (n, Instance.create n mem disk running 0 0)


  		





  50
  56
  
    

  		





  51
  
  
    
parseInstance :: NameAssoc


  		





  52
  
  
    
              -> String


  		





  53
  
  
    
              -> JSObject JSValue


  		





  
  57
  
    
-- | Parses an instance as found in the cluster instance list.


  		





  
  58
  
    
parseInstance :: NameAssoc        -- ^ The node name-to-index association list


  		





  
  59
  
    
              -> String           -- ^ The name of the instance


  		





  
  60
  
    
              -> JSObject JSValue -- ^ The JSON object


  		





  54
  61
  
    
              -> Result (String, Instance.Instance)


  		





  55
  62
  
    
parseInstance ktn n a = do


  		





  56
  63
  
    
    base <- parseBaseInstance n a


  		





  ......




  62
  69
  
    
             else (readEitherString $ head snodes) >>= lookupNode ktn n)


  		





  63
  70
  
    
    return (n, Instance.setBoth (snd base) pidx sidx)


  		





  64
  71
  
    

  		





  65
  
  
    
parseNode :: String -> JSObject JSValue -> Result (String, Node.Node)


  		





  
  72
  
    
-- | Parses a node as found in the cluster node list.


  		





  
  73
  
    
parseNode :: String           -- ^ The node's name


  		





  
  74
  
    
          -> JSObject JSValue -- ^ The JSON object


  		





  
  75
  
    
          -> Result (String, Node.Node)


  		





  66
  76
  
    
parseNode n a = do


  		





  67
  77
  
    
    let name = n


  		





  68
  78
  
    
    offline <- fromObj "offline" a


  		





  ......




  79
  89
  
    
                        dtotal dfree (offline || drained))


  		





  80
  90
  
    
    return (name, node)


  		





  81
  91
  
    

  		





  82
  
  
    
parseData :: String -> Result Request


  		





  
  92
  
    
-- | Top-level parser.


  		





  
  93
  
    
parseData :: String         -- ^ The JSON message as received from Ganeti


  		





  
  94
  
    
          -> Result Request -- ^ A (possible valid) request


  		





  83
  95
  
    
parseData body = do


  		





  84
  96
  
    
  decoded <- fromJResult $ decodeStrict body


  		





  85
  97
  
    
  let obj = decoded


  		





  ......




  116
  128
  
    
        other -> fail $ ("Invalid request type '" ++ other ++ "'")


  		





  117
  129
  
    
  return $ Request rqtype map_n map_i csf


  		





  118
  130
  
    

  		





  119
  
  
    
formatResponse :: Bool -> String -> [String] -> String


  		





  
  131
  
    
-- | Formats the response into a valid IAllocator response message.


  		





  
  132
  
    
formatResponse :: Bool     -- ^ Whether the request was successful


  		





  
  133
  
    
               -> String   -- ^ Information text


  		





  
  134
  
    
               -> [String] -- ^ The list of chosen nodes


  		





  
  135
  
    
               -> String   -- ^ The JSON-formatted message


  		





  120
  136
  
    
formatResponse success info nodes =


  		





  121
  137
  
    
    let


  		





  122
  138
  
    
        e_success = ("success", JSBool success)


  		












Also available in:
  Unified diff