File Coverage

blib/lib/Net/FreeIPA/RPC.pm
Criterion Covered Total %
statement 31 33 93.9
branch n/a
condition n/a
subroutine 11 11 100.0
pod n/a
total 42 44 95.4


line stmt bran cond sub pod time code
1             package Net::FreeIPA::RPC;
2             $Net::FreeIPA::RPC::VERSION = '3.0.2';
3 7     7   72581 use strict;
  7         10  
  7         178  
4 7     7   22 use warnings;
  7         7  
  7         150  
5              
6 7     7   3075 use Readonly;
  7         19752  
  7         383  
7              
8 7     7   2930 use REST::Client;
  7         251992  
  7         251  
9 7     7   5382 use JSON::XS;
  7         33819  
  7         492  
10              
11 7     7   3271 use Net::FreeIPA::Error;
  7         17  
  7         362  
12 7     7   3141 use Net::FreeIPA::API::Magic;
  7         17  
  7         380  
13 7     7   3285 use Net::FreeIPA::Request;
  7         13  
  7         332  
14 7     7   2831 use Net::FreeIPA::Response;
  7         13  
  7         359  
15              
16 7     7   35 use LWP::UserAgent;
  7         10  
  7         158  
17             # Add kerberos support
18 7     7   3419 use LWP::Authen::Negotiate;
  0            
  0            
19              
20             Readonly my $IPA_CA_CERT => '/etc/ipa/ca.crt';
21             Readonly my $IPA_URL_LOGIN_PASSWORD => '/ipa/session/login_password';
22             Readonly my $IPA_URL_LOGIN_KERBEROS => '/ipa/session/login_kerberos';
23             Readonly my $IPA_URL_JSON => '/ipa/session/json';
24             Readonly my $IPA_URL_REFERER => '/ipa';
25              
26             =head1 NAME
27              
28             Net::FreeIPA::RPC provides RPC handling for Net::FreeIPA
29              
30             =head2 Public methods
31              
32             =over
33              
34             =item new_rpc
35              
36             Create a new L instance, will be used throughout the remainder of the
37             instance.
38              
39             An authentication cookie will be retrieved (and will be used for the actual
40             FreeIPA API calls).
41              
42             Returns undef on failure, 1 on success.
43              
44             =over
45              
46             =item Arguments
47              
48             =over
49              
50             =item host: host to connect to
51              
52             =back
53              
54             =item Options
55              
56             =over
57              
58             =item username: the username to use for username/password based login
59              
60             =item password: the password to use for username/password login
61              
62             =item krbcc: kerberos credentials cache to use (set via KRB5CCNAME)
63              
64             =back
65              
66             =back
67              
68             =cut
69              
70             sub new_client
71             {
72             my ($self, $host, %opts) = @_;
73              
74             # Make a LWP::UserAgent with a cookiejar,
75             # connect once and reuse cookiejar for remainder
76              
77             my $url = "https://$host";
78              
79             my $browser = LWP::UserAgent->new();
80             # Temporary cookie_jar
81             $browser->cookie_jar( {} );
82              
83             my $rc = REST::Client->new(
84             host => $url,
85             ca => $IPA_CA_CERT,
86             useragent => $browser,
87             );
88              
89             my ($login_url, $body);
90             my $headers = {
91             'referer' => "$url$IPA_URL_REFERER",
92             };
93             if ($opts{username}) {
94             $self->debug("Login using username/password");
95             $login_url = $IPA_URL_LOGIN_PASSWORD;
96              
97             my $query = $rc->buildQuery(user => $opts{username}, password => $opts{password});
98             # buildQuery is for the GET method, so you have to remove the '?'
99             $body = substr($query, 1);
100              
101             $headers->{"Content-Type"} = "application/x-www-form-urlencoded";
102             $headers->{"Accept"} = "text/plain";
103             } else {
104             local $ENV{KRB5CCNAME} = $opts{krbcc} if $opts{krbcc};
105             # follow auth plugins, for LWP::Auth::Negotiate magic
106             $rc->setFollow(1);
107             $self->debug("Login using kerberos");
108             $login_url = $IPA_URL_LOGIN_KERBEROS;
109             }
110              
111             $rc->POST($login_url, $body, $headers);
112             my $code = $rc->responseCode();
113             my $content = $rc->responseContent();
114              
115             if ($code == 200) {
116             $self->debug("Successful login");
117              
118             # prep JSON REST API
119             $rc->addHeader("Content-Type", "application/json");
120             $rc->addHeader("Accept", "applicaton/json");
121             $rc->addHeader('referer', "$url$IPA_URL_REFERER");
122              
123             $self->{rc} = $rc;
124             $self->{id} = 0;
125             $self->{json} = JSON::XS->new();
126             $self->{json}->canonical(1); # sort the keys, to create reproducable results
127             $self->set_api_version('API');
128              
129             # Reset error atrribute (will be adapted by rpc method)
130             $self->{error} = mkerror();
131             return 1;
132             } else {
133             $content = '' if ! defined($content);
134             # Do no print possible password
135             $self->error("Login failed (url $url$login_url code $code): $content");
136             # Set error attribute
137             $self->{error} = mkerror("Login failed (url $url$login_url code $code)");
138             return;
139             }
140             }
141              
142             =item set_apiversion
143              
144             Set the API version for this session.
145              
146             If no version string is passed, the C attribute
147             is set to undef (effecitively removing it), and this is typically
148             interpreted by the server as using the latest version.
149              
150             If the string C is passed as version,
151             it will use verison from C.
152              
153             If the version is a C instance, the used version is
154             stringified and any leading 'v' is removed.
155              
156             Returns the version that was set version on success, undef otherwise.
157             (If you want to get the current version, use the C attribute.
158             This method will always set a version.)
159              
160             =cut
161              
162             sub set_api_version
163             {
164             my ($self, $version) = @_;
165              
166             if (defined($version)) {
167             if ( (! ref($version)) && ($version eq 'API')) {
168             $version = Net::FreeIPA::API::Magic::version();
169             $self->debug("set_api_version using API version $version");
170             };
171              
172             if (ref($version) eq 'version') {
173             $version = $version->stringify();
174             $version =~ s/^v//;
175             }
176             };
177              
178             $self->{api_version} = $version;
179             $self->debug("set api_version to ".(defined($version) ? $version : ''));
180             return $version;
181             }
182              
183             =item post
184              
185             Make a JSON API post using C.
186              
187             Return Response instance, undef on failure to get the REST client via the C attribute.
188              
189             =cut
190              
191             sub post
192             {
193             my ($self, $request, %opts) = @_;
194              
195             # set request post options, do not override
196             foreach my $postopt (sort keys %{$request->{post}}) {
197             $opts{$postopt} = $request->{post}->{$postopt} if ! defined($opts{$postopt});
198             }
199              
200             # For now, only support the API version from Net::FreeIPA::API
201             if ($self->{api_version}) {
202             $request->{opts}->{version} = $self->{api_version};
203             }
204              
205             $request->{id} = $self->{id} if ! defined($request->{id});
206              
207             # For convenience
208             my $rc = $self->{rc};
209             return if (! defined($rc));
210              
211             my $json_req = $self->{json}->encode($request->post_data());
212             $self->debug("JSON POST $json_req") if $self->{debugapi};
213             $rc->POST($IPA_URL_JSON, $json_req);
214              
215             my $code = $rc->responseCode();
216             my $content = $rc->responseContent();
217             my ($ans, $err);
218              
219             if ($code == 200) {
220             $ans = $self->{json}->decode($content);
221             $self->debug("Successful JSON POST".($self->{debugapi} ? " JSON $content" : ""));
222             } else {
223             $ans = $content;
224              
225             $content = '' if ! defined($content);
226             $self->error("POST failed (url $IPA_URL_JSON code $code): $content");
227             # Set error (not processed anymore by rpc)
228             $err = "POST failed (url $IPA_URL_JSON code $code)";
229             }
230              
231             return mkresponse(answer => $ans, error => $err);
232             }
233              
234              
235             =item rpc
236              
237             Make a JSON API rpc call.
238             Returns response on successful POST (and no error attribute is set,
239             even if the answer contains an error), undef otherwise
240             (and the error attribute is set).
241              
242             Arguments
243              
244             =over
245              
246             =item request: request instance (request rpc options are added to the options, without overriding)
247              
248             =back
249              
250             Options
251              
252             =over
253              
254             =item result_path: passed to the response
255              
256             =item noerror
257              
258             An array ref with errorcodes or errornames that are not reported as an error.
259             (Still return C).
260              
261             =back
262              
263             Response is stored in the response attribute (and is reset).
264              
265             =cut
266              
267             sub rpc
268             {
269             my ($self, $request, %opts) = @_;
270              
271             # Reset any previous result and error
272             $self->{response} = undef;
273             $self->{error} = undef;
274              
275             my ($ret, $response, $errmsg);
276              
277             my $ref = ref($request);
278             if ($ref eq 'Net::FreeIPA::Request') {
279             if ($request) {
280             # set request rpc options, do not override
281             foreach my $rpcopt (sort keys %{$request->{rpc}}) {
282             $opts{$rpcopt} = $request->{rpc}->{$rpcopt} if ! defined($opts{$rpcopt});
283             }
284              
285             $response = $self->post($request);
286             } else {
287             $errmsg = "error in request $request->{error}";
288             }
289             } else {
290             $errmsg = "Not supported rpc argument type $ref";
291             }
292              
293             if ($response) {
294             # At this point, POST was succesful, and we interpret the response
295             my $command = $request->{command};
296              
297             # Redefine the response error according to answer
298             my $error = $response->set_error($response->{answer}->{error});
299             # (re)set the result, also in case of error-in-answer,
300             # it will reset the result attribute
301             $response->set_result($opts{result_path});
302              
303             if ($error) {
304             my @noerrors = grep {defined($_) && $error == $_} @{$opts{noerror} || []};
305              
306             my $error_method = @noerrors ? 'debug' : 'error';
307              
308             $self->$error_method("$command got error ($error)");
309             } else {
310             $self->warn("$command got truncated result") if $self->{response}->{answer}->{result}->{truncated};
311             };
312              
313             # Set and return response attribute
314             $self->{response} = $response;
315             return $response;
316             } else {
317             if ($errmsg) {
318             $self->error($errmsg);
319             $self->{error} = mkerror($errmsg);
320             } else {
321             $self->{error} = $response->{error};
322             };
323             return;
324             };
325             }
326              
327              
328             # Possible code for batch
329             # requests can come from API::Function
330             # API::Function is not unittested
331             sub batch
332             {
333             my ($self, @requests) = @_;
334              
335             # Make a large batch request
336             # increase the id of each request, update the $self->id
337             # use request->post_data, make arrayref?
338             # rpc the batchrequest
339             # split the rpc batchresponse answer
340             # make a response instance for each request
341             # pass each sub-response through rpc for postprocessing
342             # extract the rpc options from each request
343             # requires change to rpc to handle responses or factor out the response post processing code
344             # return list of responses
345             }
346              
347             =item get_api_commands
348              
349             Retrieve the API commands metadata.
350              
351             The result attribute holds the commands hashref.
352              
353             Returns commands hasref on success, undef on failure.
354              
355             =cut
356              
357             sub get_api_commands
358             {
359             my ($self) = @_;
360              
361             # Cannot use the API::Function here, this is to be used to generate them
362             my $req = mkrequest('json_metadata', args => [], opts => {command => "all"});
363             my $resp = $self->rpc($req, result_path => 'result/commands');
364             return $resp ? $resp->{result} : undef;
365             }
366              
367              
368             =item get_api_version
369              
370             Retrieve the API version from the server.
371              
372             The result attribute holds the version.
373              
374             (To retrieve the latest version remove
375             the C attribute first).
376              
377             Does not set the version.
378              
379             Returns the C on success, undef on failure.
380              
381             =cut
382              
383             sub get_api_version
384             {
385             my ($self) = @_;
386              
387             # Cannot use the API::Function here, this is to be used to generate them
388             my $req = mkrequest('env', args => ['api_version'], opts => {});
389             my $resp = $self->rpc($req, result_path => 'result/result/api_version');
390             return $resp ? $resp->{result} : undef;
391             }
392              
393             =pod
394              
395             =back
396              
397             =cut
398              
399             1;