Revision 8920fa09
| b/src/Ganeti/Rpc.hs | ||
|---|---|---|
| 78 | 78 |
import Network.Curl |
| 79 | 79 |
import qualified Ganeti.Path as P |
| 80 | 80 |
|
| 81 |
import Ganeti.BasicTypes |
|
| 81 | 82 |
import qualified Ganeti.Constants as C |
| 82 | 83 |
import Ganeti.Objects |
| 83 | 84 |
import Ganeti.THH |
| 84 | 85 |
import Ganeti.Types |
| 85 |
import Ganeti.Compat |
|
| 86 |
import Ganeti.Curl.Multi |
|
| 87 |
import Ganeti.Utils |
|
| 86 | 88 |
|
| 87 | 89 |
-- * Base RPC functionality and types |
| 88 | 90 |
|
| ... | ... | |
| 151 | 153 |
, requestOpts :: [CurlOption] -- ^ The various curl options |
| 152 | 154 |
} |
| 153 | 155 |
|
| 154 |
-- | Execute the request and return the result as a plain String. When |
|
| 155 |
-- curl reports an error, we propagate it. |
|
| 156 |
executeHttpRequest :: ERpcError HttpClientRequest -> IO (ERpcError String) |
|
| 157 |
executeHttpRequest (Left rpc_err) = return $ Left rpc_err |
|
| 158 |
executeHttpRequest (Right request) = do |
|
| 159 |
let reqOpts = CurlPostFields [requestData request]:requestOpts request |
|
| 160 |
url = requestUrl request |
|
| 161 |
-- FIXME: This is very similar to getUrl in Htools/Rapi.hs |
|
| 162 |
(code, !body) <- curlGetString url $ curlOpts ++ reqOpts |
|
| 163 |
return $ case code of |
|
| 164 |
CurlOK -> Right body |
|
| 165 |
_ -> Left $ CurlLayerError (show code) |
|
| 166 |
|
|
| 167 | 156 |
-- | Prepare url for the HTTP request. |
| 168 | 157 |
prepareUrl :: (RpcCall a) => Node -> a -> String |
| 169 | 158 |
prepareUrl node call = |
| ... | ... | |
| 184 | 173 |
} |
| 185 | 174 |
| otherwise = Left OfflineNodeError |
| 186 | 175 |
|
| 176 |
-- | Parse an HTTP reply. |
|
| 177 |
parseHttpReply :: (Rpc a b) => |
|
| 178 |
a -> ERpcError (CurlCode, String) -> ERpcError b |
|
| 179 |
parseHttpReply _ (Left e) = Left e |
|
| 180 |
parseHttpReply call (Right (CurlOK, body)) = parseHttpResponse call body |
|
| 181 |
parseHttpReply _ (Right (code, err)) = |
|
| 182 |
Left . CurlLayerError $ "code: " ++ show code ++ ", explanation: " ++ err |
|
| 183 |
|
|
| 187 | 184 |
-- | Parse a result based on the received HTTP response. |
| 188 |
parseHttpResponse :: (Rpc a b) => a -> ERpcError String -> ERpcError b |
|
| 189 |
parseHttpResponse _ (Left err) = Left err |
|
| 190 |
parseHttpResponse call (Right res) = |
|
| 185 |
parseHttpResponse :: (Rpc a b) => a -> String -> ERpcError b |
|
| 186 |
parseHttpResponse call res = |
|
| 191 | 187 |
case J.decode res of |
| 192 | 188 |
J.Error val -> Left $ JsonDecodeError val |
| 193 | 189 |
J.Ok (True, res'') -> rpcResultFill call res'' |
| ... | ... | |
| 195 | 191 |
J.JSString msg -> Left $ RpcResultError (J.fromJSString msg) |
| 196 | 192 |
_ -> Left . JsonDecodeError $ show (pp_value jerr) |
| 197 | 193 |
|
| 198 |
-- | Execute RPC call for a sigle node. |
|
| 199 |
executeSingleRpcCall :: (Rpc a b) => |
|
| 200 |
[CurlOption] -> Node -> a -> IO (Node, ERpcError b) |
|
| 201 |
executeSingleRpcCall opts node call = do |
|
| 202 |
let request = prepareHttpRequest opts node call |
|
| 203 |
response <- executeHttpRequest request |
|
| 204 |
let result = parseHttpResponse call response |
|
| 205 |
return (node, result) |
|
| 206 |
|
|
| 207 | 194 |
-- | Execute RPC call for many nodes in parallel. |
| 208 | 195 |
executeRpcCall :: (Rpc a b) => [Node] -> a -> IO [(Node, ERpcError b)] |
| 209 | 196 |
executeRpcCall nodes call = do |
| ... | ... | |
| 213 | 200 |
, CurlSSLKey cert_file |
| 214 | 201 |
, CurlCAInfo cert_file |
| 215 | 202 |
] |
| 216 |
sequence $ parMap rwhnf (\n -> executeSingleRpcCall opts n call) nodes |
|
| 203 |
opts_urls = map (\n -> |
|
| 204 |
case prepareHttpRequest opts n call of |
|
| 205 |
Left v -> Left v |
|
| 206 |
Right request -> |
|
| 207 |
Right (CurlPostFields [requestData request]: |
|
| 208 |
requestOpts request, |
|
| 209 |
requestUrl request) |
|
| 210 |
) nodes |
|
| 211 |
-- split the opts_urls list; we don't want to pass the |
|
| 212 |
-- failed-already nodes to Curl |
|
| 213 |
let (lefts, rights, trail) = splitEithers opts_urls |
|
| 214 |
results <- execMultiCall rights |
|
| 215 |
results' <- case recombineEithers lefts results trail of |
|
| 216 |
Bad msg -> error msg |
|
| 217 |
Ok r -> return r |
|
| 218 |
-- now parse the replies |
|
| 219 |
let results'' = map (parseHttpReply call) results' |
|
| 220 |
return $ zip nodes results'' |
|
| 217 | 221 |
|
| 218 | 222 |
-- | Helper function that is used to read dictionaries of values. |
| 219 | 223 |
sanitizeDictResults :: [(String, J.Result a)] -> ERpcError [(String, a)] |
Also available in: Unified diff