Fix parsing of absolute job dependencies

[ganeti-local] / htools / Ganeti / Rpc.hs

diff --git a/htools/Ganeti/Rpc.hs b/htools/Ganeti/Rpc.hs
index 0772c8f..4ab9d7e 100644 (file)
--- a/htools/Ganeti/Rpc.hs
+++ b/htools/Ganeti/Rpc.hs
@@ -59,18 +59,19 @@ module Ganeti.Rpc
   , RpcCallVersion(..)
   , RpcResultVersion(..)
 
-  , StorageType(..)
   , StorageField(..)
   , RpcCallStorageList(..)
   , RpcResultStorageList(..)
 
+  , RpcCallTestDelay(..)
+  , RpcResultTestDelay(..)
+
   , rpcTimeoutFromRaw -- FIXME: Not used anywhere
   ) where
 
 import Control.Arrow (second)
 import qualified Text.JSON as J
 import Text.JSON.Pretty (pp_value)
-import Text.JSON (makeObj)
 
 #ifndef NO_CURL
 import Network.Curl
@@ -80,20 +81,19 @@ import qualified Ganeti.Path as P
 import qualified Ganeti.Constants as C
 import Ganeti.Objects
 import Ganeti.THH
+import Ganeti.Types
 import Ganeti.Compat
-import Ganeti.JSON
+
+-- * Base RPC functionality and types
 
 #ifndef NO_CURL
 -- | The curl options used for RPC.
 curlOpts :: [CurlOption]
 curlOpts = [ CurlFollowLocation False
-           , CurlCAInfo P.nodedCertFile
            , CurlSSLVerifyHost 0
            , CurlSSLVerifyPeer True
            , CurlSSLCertType "PEM"
-           , CurlSSLCert P.nodedCertFile
            , CurlSSLKeyType "PEM"
-           , CurlSSLKey P.nodedCertFile
            , CurlConnectTimeout (fromIntegral C.rpcConnectTimeout)
            ]
 #endif
@@ -166,8 +166,12 @@ executeHttpRequest _ (Left rpc_err) = return $ Left rpc_err
 executeHttpRequest _ _ = return $ Left CurlDisabledError
 #else
 executeHttpRequest node (Right request) = do
+  cert_file <- P.nodedCertFile
   let reqOpts = [ CurlTimeout (fromIntegral $ requestTimeout request)
                 , CurlPostFields [requestPostData request]
+                , CurlSSLCert cert_file
+                , CurlSSLKey cert_file
+                , CurlCAInfo cert_file
                 ]
       url = requestUrl request
   -- FIXME: This is very similar to getUrl in Htools/Rapi.hs
@@ -224,12 +228,12 @@ executeRpcCall nodes call =
 
 -- | Helper function that is used to read dictionaries of values.
 sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)]
-sanitizeDictResults [] = Right []
-sanitizeDictResults ((_, J.Error err):_) = Left $ JsonDecodeError err
-sanitizeDictResults ((name, J.Ok val):xs) =
-  case sanitizeDictResults xs of
-    Left err -> Left err
-    Right res' -> Right $ (name, val):res'
+sanitizeDictResults =
+  foldr sanitize1 (Right [])
+  where
+    sanitize1 _ (Left e) = Left e
+    sanitize1 (_, J.Error e) _ = Left $ JsonDecodeError e
+    sanitize1 (name, J.Ok v) (Right res) = Right $ (name, v) : res
 
 -- | Helper function to tranform JSON Result to Either RpcError b.
 -- Note: For now we really only use it for b s.t. Rpc c b for some c
@@ -243,6 +247,8 @@ fromJSValueToRes val = fromJResultToRes (J.readJSON val)
 
 -- * RPC calls and results
 
+-- ** Instance info
+
 -- | InstanceInfo
 --   Returns information about a single instance.
 
@@ -282,6 +288,8 @@ instance Rpc RpcCallInstanceInfo RpcResultInstanceInfo where
       _ -> Left $ JsonDecodeError
            ("Expected JSObject, got " ++ show (pp_value res))
 
+-- ** AllInstancesInfo
+
 -- | AllInstancesInfo
 --   Returns information about all running instances on the given nodes
 $(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
@@ -309,6 +317,8 @@ instance Rpc RpcCallAllInstancesInfo RpcResultAllInstancesInfo where
       _ -> Left $ JsonDecodeError
            ("Expected JSObject, got " ++ show (pp_value res))
 
+-- ** InstanceList
+
 -- | InstanceList
 -- Returns the list of running instances on the given nodes.
 $(buildObject "RpcCallInstanceList" "rpcCallInstList"
@@ -326,6 +336,8 @@ instance RpcCall RpcCallInstanceList where
 instance Rpc RpcCallInstanceList RpcResultInstanceList where
   rpcResultFill _ res = fromJSValueToRes res RpcResultInstanceList
 
+-- ** NodeInfo
+
 -- | NodeInfo
 -- Return node information.
 $(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
@@ -368,11 +380,13 @@ instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
   rpcResultFill _ res =
     fromJSValueToRes res (\(b, vg, hv) -> RpcResultNodeInfo b vg hv)
 
+-- ** Version
+
 -- | Version
 -- Query node version.
 -- Note: We can't use THH as it does not know what to do with empty dict
 data RpcCallVersion = RpcCallVersion {}
-  deriving (Show, Read, Eq)
+  deriving (Show, Eq)
 
 instance J.JSON RpcCallVersion where
   showJSON _ = J.JSNull
@@ -387,20 +401,14 @@ instance RpcCall RpcCallVersion where
   rpcCallName _          = "version"
   rpcCallTimeout _       = rpcTimeoutToRaw Urgent
   rpcCallAcceptOffline _ = True
-  rpcCallData call _     = J.encode [call]
+  rpcCallData _          = J.encode
 
 instance Rpc RpcCallVersion RpcResultVersion where
   rpcResultFill _ res = fromJSValueToRes res RpcResultVersion
 
+-- ** StorageList
+
 -- | StorageList
--- Get list of storage units.
--- FIXME: This may be moved to Objects
-$(declareSADT "StorageType"
-  [ ( "STLvmPv", 'C.stLvmPv )
-  , ( "STFile",  'C.stFile )
-  , ( "STLvmVg", 'C.stLvmVg )
-  ])
-$(makeJSONInstance ''StorageType)
 
 -- FIXME: This may be moved to Objects
 $(declareSADT "StorageField"
@@ -439,3 +447,30 @@ instance Rpc RpcCallStorageList RpcResultStorageList where
   rpcResultFill call res =
     let sfields = rpcCallStorageListFields call in
     fromJSValueToRes res (RpcResultStorageList . map (zip sfields))
+
+-- ** TestDelay
+
+
+-- | Call definition for test delay.
+$(buildObject "RpcCallTestDelay" "rpcCallTestDelay"
+  [ simpleField "duration" [t| Double |]
+  ])
+
+-- | Result definition for test delay.
+data RpcResultTestDelay = RpcResultTestDelay
+                          deriving Show
+
+-- | Custom JSON instance for null result.
+instance J.JSON RpcResultTestDelay where
+  showJSON _        = J.JSNull
+  readJSON J.JSNull = return RpcResultTestDelay
+  readJSON _        = fail "Unable to read RpcResultTestDelay"
+
+instance RpcCall RpcCallTestDelay where
+  rpcCallName _          = "test_delay"
+  rpcCallTimeout         = ceiling . (+ 5) . rpcCallTestDelayDuration
+  rpcCallAcceptOffline _ = False
+  rpcCallData _ call     = J.encode [rpcCallTestDelayDuration call]
+
+instance Rpc RpcCallTestDelay RpcResultTestDelay where
+  rpcResultFill _ res = fromJSValueToRes res id