File Coverage

blib/lib/JMAP/Tester.pm
Criterion Covered Total %
statement 83 265 31.3
branch 5 88 5.6
condition 0 27 0.0
subroutine 26 51 50.9
pod 12 16 75.0
total 126 447 28.1


line stmt bran cond sub pod time code
1 1     1   33133 use v5.14.0;
  1         12  
2 1     1   6 use warnings;
  1         2  
  1         40  
3              
4             package JMAP::Tester 0.103;
5             # ABSTRACT: a JMAP client made for testing JMAP servers
6              
7 1     1   578 use Moo;
  1         12756  
  1         5  
8              
9 1     1   2020 use Crypt::Misc qw(decode_b64u encode_b64u);
  1         22063  
  1         106  
10 1     1   435 use Crypt::Mac::HMAC qw(hmac_b64u);
  1         1272  
  1         59  
11 1     1   498 use Encode qw(encode_utf8);
  1         14685  
  1         99  
12 1     1   637 use Future;
  1         14359  
  1         41  
13 1     1   442 use HTTP::Request;
  1         1101  
  1         35  
14 1     1   449 use JMAP::Tester::Abort 'abort';
  1         4  
  1         8  
15 1     1   631 use JMAP::Tester::Logger::Null;
  1         4  
  1         42  
16 1     1   546 use JMAP::Tester::Response;
  1         3  
  1         38  
17 1     1   474 use JMAP::Tester::Result::Auth;
  1         3  
  1         35  
18 1     1   411 use JMAP::Tester::Result::Download;
  1         3  
  1         33  
19 1     1   428 use JMAP::Tester::Result::Failure;
  1         2  
  1         33  
20 1     1   410 use JMAP::Tester::Result::Logout;
  1         2  
  1         32  
21 1     1   417 use JMAP::Tester::Result::Upload;
  1         3  
  1         34  
22 1     1   8 use Module::Runtime ();
  1         2  
  1         23  
23 1     1   4 use Params::Util qw(_HASH0 _ARRAY0);
  1         3  
  1         65  
24 1     1   508 use Safe::Isa;
  1         556  
  1         138  
25 1     1   7 use URI;
  1         2  
  1         28  
26 1     1   425 use URI::QueryParam;
  1         861  
  1         36  
27 1     1   6 use URI::Escape qw(uri_escape);
  1         3  
  1         66  
28              
29 1     1   6 use namespace::clean;
  1         3  
  1         9  
30              
31             #pod =head1 OVERVIEW
32             #pod
33             #pod B This library is in its really early days, so use it with that in
34             #pod mind.
35             #pod
36             #pod JMAP::Tester is for testing JMAP servers. Okay? Okay!
37             #pod
38             #pod JMAP::Tester calls the whole thing you get back from a JMAP server a "response"
39             #pod if it's an HTTP 200. Every JSON Array (of three entries -- go read the spec if
40             #pod you need to!) is called a L. Runs
41             #pod of Sentences with the same client id are called
42             #pod L.
43             #pod
44             #pod You use the test client like this:
45             #pod
46             #pod my $jtest = JMAP::Tester->new({
47             #pod api_uri => 'https://jmap.local/account/123',
48             #pod });
49             #pod
50             #pod my $response = $jtest->request([
51             #pod [ getMailboxes => {} ],
52             #pod [ getMessageUpdates => { sinceState => "123" } ],
53             #pod ]);
54             #pod
55             #pod # This returns two Paragraph objects if there are exactly two paragraphs.
56             #pod # Otherwise, it throws an exception.
57             #pod my ($mbx_p, $msg_p) = $response->assert_n_paragraphs(2);
58             #pod
59             #pod # These get the single Sentence of each paragraph, asserting that there is
60             #pod # exactly one Sentence in each Paragraph, and that it's of the given type.
61             #pod my $mbx = $mbx_p->single('mailboxes');
62             #pod my $msg = $msg_p->single('messageUpdates');
63             #pod
64             #pod is( @{ $mbx->arguments->{list} }, 10, "we expect 10 mailboxes");
65             #pod ok( ! $msg->arguments->{hasMoreUpdates}, "we got all the msg updates needed");
66             #pod
67             #pod By default, all the structures returned have been passed through
68             #pod L, so you may want to strip their type data before using normal
69             #pod Perl code on them. You can do that with:
70             #pod
71             #pod my $struct = $response->as_triples; # gets the complete JSON data
72             #pod $jtest->strip_json_types( $struct ); # strips all the JSON::Typist types
73             #pod
74             #pod Or more simply:
75             #pod
76             #pod my $struct = $response->as_stripped_triples;
77             #pod
78             #pod There is also L.
79             #pod
80             #pod =cut
81              
82             #pod =attr should_return_futures
83             #pod
84             #pod If true, this indicates that the various network-accessing methods should
85             #pod return L objects rather than immediate results.
86             #pod
87             #pod =cut
88              
89             has should_return_futures => (
90             is => 'ro',
91             default => 0,
92             );
93              
94             # When something doesn't work — not an individual method call, but the whole
95             # HTTP call, somehow — then the future will fail, and the failure might be a
96             # JMAP tester failure object, meaning we semi-expected it, or it might be some
97             # other crazy failure, meaning we had no way of seeing it coming.
98             #
99             # We use Future->fail because that way we can use ->else in chains to only act
100             # on successful HTTP calls. At the end, it's fine if you're expecting a future
101             # and can know that a failed future is a fail and a done future is okay. In the
102             # old calling convention, though, you expect to get a success/fail object as
103             # long as you got an HTTP response. Otherwise, you'd get an exception.
104             #
105             # $Failsafe emulates that. Just before we return from a future-returning
106             # method, and if the client is not set to return futures, we do this:
107             #
108             # * successful futures return their payload, the Result object
109             # * failed futures that contain a JMAP tester Failure return the failure
110             # * other failed futures die, like they would if you called $failed_future->get
111             my $Failsafe = sub {
112             $_[0]->else_with_f(sub {
113             my ($f, $fail) = @_;
114             return $fail->$_isa('JMAP::Tester::Result::Failure') ? Future->done($fail)
115             : $f;
116             });
117             };
118              
119             has json_codec => (
120             is => 'bare',
121             handles => {
122             json_encode => 'encode',
123             json_decode => 'decode',
124             },
125             default => sub {
126             require JSON;
127             return JSON->new->utf8->convert_blessed;
128             },
129             );
130              
131             #pod =attr use_json_typists
132             #pod
133             #pod This attribute governs the conversion of JSON data into typed objects, using
134             #pod L. This attribute is true by default.
135             #pod
136             #pod =cut
137              
138             has use_json_typist => (
139             is => 'ro',
140             default => 1,
141             );
142              
143             has _json_typist => (
144             is => 'ro',
145             handles => {
146             strip_json_types => 'strip_types',
147             },
148             default => sub {
149             require JSON::Typist;
150             return JSON::Typist->new;
151             },
152             );
153              
154             sub apply_json_types {
155 4     4 0 179 my ($self, $data) = @_;
156              
157 4 100       22 return $data unless $self->use_json_typist;
158 3         20 return $self->_json_typist->apply_types($data);
159             }
160              
161             for my $type (qw(api authentication download upload)) {
162             has "$type\_uri" => (
163             is => 'rw',
164             predicate => "has_$type\_uri",
165             clearer => "clear_$type\_uri",
166             );
167             }
168              
169             has ua => (
170             is => 'ro',
171             default => sub {
172             require JMAP::Tester::UA::LWP;
173             JMAP::Tester::UA::LWP->new;
174             },
175             );
176              
177             #pod =attr default_using
178             #pod
179             #pod This is an arrayref of strings that specify which capabilities the client
180             #pod wishes to use. (See L
181             #pod for more info). By default, JMAP::Tester will not send a 'using' parameter.
182             #pod
183             #pod =cut
184              
185             has default_using => (
186             is => 'rw',
187             predicate => '_has_default_using',
188             );
189              
190             #pod =attr default_arguments
191             #pod
192             #pod This is a hashref of arguments to be put into each method call. It's
193             #pod especially useful for setting a default C. Values given in methods
194             #pod passed to C will override defaults. If the value is a reference to
195             #pod C, then no value will be passed for that key.
196             #pod
197             #pod In other words, in this situation:
198             #pod
199             #pod my $tester = JMAP::Tester->new({
200             #pod ...,
201             #pod default_arguments => { a => 1, b => 2, c => 3 },
202             #pod });
203             #pod
204             #pod $tester->request([
205             #pod [ eatPies => { a => 100, b => \undef } ],
206             #pod ]);
207             #pod
208             #pod The request will effectively be:
209             #pod
210             #pod [ [ "eatPies", { "a": 100, "c": 3 }, "a" ] ]
211             #pod
212             #pod =cut
213              
214             has default_arguments => (
215             is => 'rw',
216             default => sub { {} },
217             );
218              
219             #pod =attr accounts
220             #pod
221             #pod This method will return a list of pairs mapping accountIds to accounts
222             #pod as provided by the client session object if any have been configured.
223             #pod
224             #pod =cut
225              
226             has _accounts => (
227             is => 'rw',
228             init_arg => undef,
229             predicate => '_has_accounts',
230             );
231              
232             sub accounts {
233 0 0   0 1 0 return unless $_[0]->_has_accounts;
234 0         0 return %{ $_[0]->_accounts }
  0         0  
235             }
236              
237             #pod =method primary_account_for
238             #pod
239             #pod my $account_id = $tester->primary_account_for($using);
240             #pod
241             #pod This returns the primary accountId to be used for the given capability, or
242             #pod undef if none is available. This is only useful if the tester has been
243             #pod configured from a client session.
244             #pod
245             #pod =cut
246              
247             has _primary_accounts => (
248             is => 'rw',
249             init_arg => undef,
250             predicate => '_has_primary_accounts',
251             );
252              
253             sub primary_account_for {
254 0     0 1 0 my ($self, $using) = @_;
255 0 0       0 return unless $self->_has_primary_accounts;
256 0         0 return $self->_primary_accounts->{ $using };
257             }
258              
259             #pod =method request
260             #pod
261             #pod my $result = $jtest->request([
262             #pod [ methodOne => { ... } ],
263             #pod [ methodTwo => { ... } ],
264             #pod ]);
265             #pod
266             #pod This method accepts either an arrayref of method calls or a hashref with a
267             #pod C key. It sends the calls to the JMAP server and returns a
268             #pod result.
269             #pod
270             #pod For each method call, if there's a third element (a I) then it's
271             #pod left as-is. If no client id is given, one is generated. You can mix explicit
272             #pod and autogenerated client ids. They will never conflict.
273             #pod
274             #pod The arguments to methods are JSON-encoded with a L-aware encoder,
275             #pod so JSON::Typist types can be used to ensure string or number types in the
276             #pod generated JSON. If an argument is a reference to C, it will be removed
277             #pod before the method call is made. This lets you override a default by omission.
278             #pod
279             #pod The return value is an object that does the L role,
280             #pod meaning it's got an C method that returns true or false. For now,
281             #pod at least, failures are L objects. More refined
282             #pod failure objects may exist in the future. Successful requests return
283             #pod L objects.
284             #pod
285             #pod Before the JMAP request is made, each triple is passed to a method called
286             #pod C, which can tweak the method however it likes.
287             #pod
288             #pod This method respects the C attributes of the
289             #pod JMAP::Tester object, and in futures mode will return a future that will resolve
290             #pod to the Result.
291             #pod
292             #pod =cut
293              
294             sub request {
295 0     0 1 0 my ($self, $input_request) = @_;
296              
297 0 0       0 Carp::confess("can't perform request: no api_uri configured")
298             unless $self->has_api_uri;
299              
300 0         0 state $ident = 'a';
301 0         0 my %seen;
302             my @suffixed;
303              
304 0         0 my %default_args = %{ $self->default_arguments };
  0         0  
305              
306 0 0       0 my $request = _ARRAY0($input_request)
307             ? { methodCalls => $input_request }
308             : { %$input_request };
309              
310 0         0 for my $call (@{ $request->{methodCalls} }) {
  0         0  
311 0         0 my $copy = [ @$call ];
312 0 0       0 if (defined $copy->[2]) {
313 0         0 $seen{$call->[2]}++;
314             } else {
315 0         0 my $next;
316 0         0 do { $next = $ident++ } until ! $seen{$ident}++;
  0         0  
317 0         0 $copy->[2] = $next;
318             }
319              
320             my %arg = (
321             %default_args,
322 0   0     0 %{ $copy->[1] // {} },
  0         0  
323             );
324              
325 0         0 for my $key (keys %arg) {
326 0 0 0     0 if ( ref $arg{$key}
      0        
327             && ref $arg{$key} eq 'SCALAR'
328 0         0 && ! defined ${ $arg{$key} }
329             ) {
330 0         0 delete $arg{$key};
331             }
332             }
333              
334 0         0 $copy->[1] = \%arg;
335              
336             # Originally, I had a second argument, \%stash, which was the same for the
337             # whole ->request, so you could store data between munges. Removed, for
338             # now, as YAGNI. -- rjbs, 2019-03-04
339 0         0 $self->munge_method_triple($copy);
340              
341 0         0 push @suffixed, $copy;
342             }
343              
344 0         0 $request->{methodCalls} = \@suffixed;
345              
346             $request = $request->{methodCalls}
347 0 0 0     0 if $ENV{JMAP_TESTER_NO_WRAPPER} && _ARRAY0($input_request);
348              
349 0 0 0     0 if ($self->_has_default_using && ! exists $request->{using}) {
350 0         0 $request->{using} = $self->default_using;
351             }
352              
353 0         0 my $json = $self->json_encode($request);
354              
355 0         0 my $post = HTTP::Request->new(
356             POST => $self->api_uri,
357             [
358             'Content-Type' => 'application/json',
359             $self->_maybe_auth_header,
360             ],
361             $json,
362             );
363              
364 0         0 my $res_f = $self->ua->request($self, $post, jmap => {
365             jmap_array => \@suffixed,
366             json => $json,
367             });
368              
369             my $future = $res_f->then(sub {
370 0     0   0 my ($res) = @_;
371              
372 0 0       0 unless ($res->is_success) {
373 0         0 $self->_logger->log_jmap_response({ http_response => $res });
374 0         0 return Future->fail(
375             JMAP::Tester::Result::Failure->new({ http_response => $res })
376             );
377             }
378              
379 0         0 return Future->done($self->_jresponse_from_hresponse($res));
380 0         0 });
381              
382 0 0       0 return $self->should_return_futures ? $future : $future->$Failsafe->get;
383             }
384              
385       0 0   sub munge_method_triple {}
386              
387 4     4 0 120 sub response_class { 'JMAP::Tester::Response' }
388              
389             sub _jresponse_from_hresponse {
390 4     4   6672 my ($self, $http_res) = @_;
391              
392             # TODO check that it's really application/json!
393 4         21 my $json = $http_res->decoded_content;
394              
395 4         895 my $data = $self->apply_json_types( $self->json_decode( $json ) );
396              
397 4         381 my ($items, $props);
398 4 100       30 if (_HASH0($data)) {
    50          
399 3         6 $props = $data;
400 3         7 $items = $props->{methodResponses};
401             } elsif (_ARRAY0($data)) {
402 1         4 $props = {};
403 1         3 $items = $data;
404             } else {
405 0         0 abort("illegal response to JMAP request: $data");
406             }
407              
408 4         46 $self->_logger->log_jmap_response({
409             jmap_array => $items,
410             json => $json,
411             http_response => $http_res,
412             });
413              
414 4         18 return $self->response_class->new({
415             items => $items,
416             http_response => $http_res,
417             wrapper_properties => $props,
418             });
419             }
420              
421             has _logger => (
422             is => 'ro',
423             default => sub {
424             if ($ENV{JMAP_TESTER_LOGGER}) {
425             my ($class, $filename) = split /:/, $ENV{JMAP_TESTER_LOGGER};
426             $class = "JMAP::Tester::Logger::$class";
427             Module::Runtime::require_module($class);
428              
429             return $class->new({
430             writer => $filename // 'jmap-tester-{T}-{PID}.log'
431             });
432             }
433              
434             JMAP::Tester::Logger::Null->new({ writer => \undef });
435             },
436             );
437              
438             #pod =method upload
439             #pod
440             #pod my $result = $tester->upload(\%arg);
441             #pod
442             #pod Required arguments are:
443             #pod
444             #pod accountId - the account for which we're uploading (no default)
445             #pod type - the content-type we want to provide to the server
446             #pod blob - the data to upload. Must be a reference to a string
447             #pod
448             #pod This uploads the given blob.
449             #pod
450             #pod The return value will either be a L
451             #pod object|JMAP::Tester::Result::Failure> or an L
452             #pod result|JMAP::Tester::Result::Upload>.
453             #pod
454             #pod This method respects the C attributes of the
455             #pod JMAP::Tester object, and in futures mode will return a future that will resolve
456             #pod to the Result.
457             #pod
458             #pod =cut
459              
460             sub upload {
461 0     0 1   my ($self, $arg) = @_;
462             # TODO: support blob as handle or sub -- rjbs, 2016-11-17
463              
464 0           my $uri = $self->upload_uri;
465              
466 0 0         Carp::confess("can't upload without upload_uri")
467             unless $uri;
468              
469 0           for my $param (qw(accountId type blob)) {
470 0           my $value = $arg->{ $param };
471              
472 0 0         Carp::confess("missing required parameter $param")
473             unless defined $value;
474              
475 0 0         if ($param eq 'accountId') {
476 0           $uri =~ s/\{$param\}/$value/g;
477             }
478             }
479              
480             my $post = HTTP::Request->new(
481             POST => $uri,
482             [
483             'Content-Type' => $arg->{type},
484             $self->_maybe_auth_header,
485             ],
486 0           ${ $arg->{blob} },
  0            
487             );
488              
489 0           my $res_f = $self->ua->request($self, $post, 'upload');
490              
491             my $future = $res_f->then(sub {
492 0     0     my ($res) = @_;
493              
494 0 0         unless ($res->is_success) {
495 0           $self->_logger->log_upload_response({ http_response => $res });
496 0           return Future->fail(
497             JMAP::Tester::Result::Failure->new({ http_response => $res })
498             );
499             }
500              
501 0           my $json = $res->decoded_content;
502 0           my $blob = $self->apply_json_types( $self->json_decode( $json ) );
503              
504 0           $self->_logger->log_upload_response({
505             json => $json,
506             blob_struct => $blob,
507             http_response => $res,
508             });
509              
510 0           return Future->done(
511             JMAP::Tester::Result::Upload->new({
512             http_response => $res,
513             payload => $blob,
514             })
515             );
516 0           });
517              
518 0 0         return $self->should_return_futures ? $future : $future->$Failsafe->get;
519             }
520              
521             #pod =method download
522             #pod
523             #pod my $result = $tester->download(\%arg);
524             #pod
525             #pod Valid arguments are:
526             #pod
527             #pod blobId - the blob to download (no default)
528             #pod accountId - the account for which we're downloading (no default)
529             #pod type - the content-type we want the server to provide back (no default)
530             #pod name - the name we want the server to provide back (default: "download")
531             #pod
532             #pod If the download URI template has a C, C, or C
533             #pod placeholder but no argument for that is given to C, an exception
534             #pod will be thrown.
535             #pod
536             #pod The return value will either be a L
537             #pod object|JMAP::Tester::Result::Failure> or an L
538             #pod result|JMAP::Tester::Result::Download>.
539             #pod
540             #pod This method respects the C attributes of the
541             #pod JMAP::Tester object, and in futures mode will return a future that will resolve
542             #pod to the Result.
543             #pod
544             #pod =cut
545              
546             my %DL_DEFAULT = (name => 'download');
547              
548             sub _jwt_sub_param_from_uri {
549 0     0     my ($self, $to_sign) = @_;
550 0           "$to_sign";
551             }
552              
553             sub download_uri_for {
554 0     0 0   my ($self, $arg) = @_;
555              
556 0 0         Carp::confess("can't compute download URI without configured download_uri")
557             unless my $uri = $self->download_uri;
558              
559 0           for my $param (qw(blobId accountId name type)) {
560 0 0         next unless $uri =~ /\{$param\}/;
561 0   0       my $value = $arg->{ $param } // $DL_DEFAULT{ $param };
562              
563 0 0         Carp::confess("missing required template parameter $param")
564             unless defined $value;
565              
566 0 0         if ($param eq 'name') {
567 0           $value = uri_escape($value);
568             }
569              
570 0           $uri =~ s/\{$param\}/$value/g;
571             }
572              
573 0 0         if (my $jwtc = $self->_get_jwt_config) {
574 0           my $to_get = URI->new($uri);
575 0           my $to_sign = $to_get->clone->canonical;
576              
577 0           $to_sign->query(undef);
578              
579 0           my $header = encode_b64u( $self->json_encode({
580             alg => 'HS256',
581             typ => 'JWT',
582             }) );
583              
584 0           my $iat = time;
585 0           $iat = $iat - ($iat % 3600);
586              
587             my $payload = encode_b64u( $self->json_encode({
588             iss => $jwtc->{signingId},
589 0           iat => $iat,
590             sub => $self->_jwt_sub_param_from_uri($to_sign),
591             }) );
592              
593             my $signature = hmac_b64u(
594             'SHA256',
595 0           decode_b64u($jwtc->{signingKey}),
596             "$header.$payload",
597             );
598              
599 0           $to_get->query_param(access_token => "$header.$payload.$signature");
600 0           $uri = "$to_get";
601             }
602              
603 0           return $uri;
604             }
605              
606             sub download {
607 0     0 1   my ($self, $arg) = @_;
608              
609 0           my $uri = $self->download_uri_for($arg);
610              
611 0           my $get = HTTP::Request->new(
612             GET => $uri,
613             [
614             $self->_maybe_auth_header,
615             ],
616             );
617              
618 0           my $res_f = $self->ua->request($self, $get, 'download');
619              
620             my $future = $res_f->then(sub {
621 0     0     my ($res) = @_;
622              
623 0           $self->_logger->log_download_response({
624             http_response => $res,
625             });
626              
627 0 0         unless ($res->is_success) {
628 0           return Future->fail(
629             JMAP::Tester::Result::Failure->new({ http_response => $res })
630             );
631             }
632              
633 0           return Future->done(
634             JMAP::Tester::Result::Download->new({ http_response => $res })
635             );
636 0           });
637              
638 0 0         return $self->should_return_futures ? $future : $future->$Failsafe->get;
639             }
640              
641             #pod =method simple_auth
642             #pod
643             #pod my $auth_struct = $tester->simple_auth($username, $password);
644             #pod
645             #pod This method respects the C attributes of the
646             #pod JMAP::Tester object, and in futures mode will return a future that will resolve
647             #pod to the Result.
648             #pod
649             #pod =cut
650              
651             sub _maybe_auth_header {
652 0     0     my ($self) = @_;
653 0 0         return ($self->_access_token
654             ? (Authorization => "Bearer " . $self->_access_token)
655             : ());
656             }
657              
658             has _jwt_config => (
659             is => 'rw',
660             init_arg => undef,
661             );
662              
663             sub _now_timestamp {
664             # 0 1 2 3 4 5
665 0     0     my ($sec, $min, $hour, $mday, $mon, $year) = gmtime;
666 0           return sprintf '%04u-%02u-%02uT%02u:%02u:%02uZ',
667             $year + 1900, $mon + 1, $mday,
668             $hour, $min, $sec;
669             }
670              
671             sub _get_jwt_config {
672 0     0     my ($self) = @_;
673 0 0         return unless my $jwtc = $self->_jwt_config;
674 0 0         return $jwtc unless $jwtc->{signingKeyValidUntil};
675 0 0         return $jwtc if $jwtc->{signingKeyValidUntil} gt $self->_now_timestamp;
676              
677 0           $self->update_client_session;
678 0 0         return unless $jwtc = $self->_jwt_config;
679 0           return $jwtc;
680             }
681              
682             has _access_token => (
683             is => 'rw',
684             init_arg => undef,
685             );
686              
687             sub simple_auth {
688 0     0 1   my ($self, $username, $password) = @_;
689              
690             # This is fatal, not a failure return, because it reflects the user screwing
691             # up, not a possible JMAP-related condition. -- rjbs, 2016-11-17
692 0 0         Carp::confess("can't simple_auth: no authentication_uri configured")
693             unless $self->has_authentication_uri;
694              
695 0   0       my $start_json = $self->json_encode({
696             username => $username,
697             clientName => (ref $self),
698             clientVersion => $self->VERSION // '0',
699             deviceName => 'JMAP Testing Client',
700             });
701              
702 0           my $start_req = HTTP::Request->new(
703             POST => $self->authentication_uri,
704             [
705             'Content-Type' => 'application/json; charset=utf-8',
706             'Accept' => 'application/json',
707             ],
708             $start_json,
709             );
710              
711 0           my $start_res_f = $self->ua->request($self, $start_req, 'auth');
712              
713             my $future = $start_res_f->then(sub {
714 0     0     my ($res) = @_;
715              
716 0 0         unless ($res->code == 200) {
717 0           return Future->fail(
718             JMAP::Tester::Result::Failure->new({
719             ident => 'failure in auth phase 1',
720             http_response => $res,
721             })
722             );
723             }
724              
725 0           my $start_reply = $self->json_decode( $res->decoded_content );
726              
727 0 0         unless (grep {; $_->{type} eq 'password' } @{ $start_reply->{methods} }) {
  0            
  0            
728 0           return Future->fail(
729             JMAP::Tester::Result::Failure->new({
730             ident => "password is not an authentication method",
731             http_response => $res,
732             })
733             );
734             }
735              
736             my $next_json = $self->json_encode({
737             loginId => $start_reply->{loginId},
738 0           type => 'password',
739             value => $password,
740             });
741              
742 0           my $next_req = HTTP::Request->new(
743             POST => $self->authentication_uri,
744             [
745             'Content-Type' => 'application/json; charset=utf-8',
746             'Accept' => 'application/json',
747             ],
748             $next_json,
749             );
750              
751 0           return $self->ua->request($self, $next_req, 'auth');
752             })->then(sub {
753 0     0     my ($res) = @_;
754 0 0         unless ($res->code == 201) {
755 0           return Future->fail(
756             JMAP::Tester::Result::Failure->new({
757             ident => 'failure in auth phase 2',
758             http_response => $res,
759             })
760             );
761             }
762              
763 0           my $client_session = $self->json_decode( $res->decoded_content );
764              
765 0           my $auth = JMAP::Tester::Result::Auth->new({
766             http_response => $res,
767             client_session => $client_session,
768             });
769              
770 0           $self->configure_from_client_session($client_session);
771              
772 0           return Future->done($auth);
773 0           });
774              
775 0 0         return $self->should_return_futures ? $future : $future->$Failsafe->get;
776             }
777              
778             #pod =method update_client_session
779             #pod
780             #pod $tester->update_client_session;
781             #pod $tester->update_client_session($auth_uri);
782             #pod
783             #pod This method fetches the content at the authentication endpoint and uses it to
784             #pod configure the tester's target URIs and signing keys.
785             #pod
786             #pod This method respects the C attributes of the
787             #pod JMAP::Tester object, and in futures mode will return a future that will resolve
788             #pod to the Result.
789             #pod
790             #pod =cut
791              
792             sub update_client_session {
793 0     0 1   my ($self, $auth_uri) = @_;
794 0   0       $auth_uri //= $self->authentication_uri;
795              
796 0           my $auth_req = HTTP::Request->new(
797             GET => $auth_uri,
798             [
799             $self->_maybe_auth_header,
800             'Accept' => 'application/json',
801             ],
802             );
803              
804             my $future = $self->ua->request($self, $auth_req, 'auth')->then(sub {
805 0     0     my ($res) = @_;
806              
807 0 0         unless ($res->code == 200) {
808 0           return Future->fail(
809             JMAP::Tester::Result::Failure->new({
810             ident => 'failure to get updated authentication data',
811             http_response => $res,
812             })
813             );
814             }
815              
816 0           my $client_session = $self->json_decode( $res->decoded_content );
817              
818 0           my $auth = JMAP::Tester::Result::Auth->new({
819             http_response => $res,
820             client_session => $client_session,
821             });
822              
823 0           $self->configure_from_client_session($client_session);
824              
825 0           return Future->done($auth);
826 0           });
827              
828 0 0         return $self->should_return_futures ? $future : $future->$Failsafe->get;
829             }
830              
831             #pod =method configure_from_client_session
832             #pod
833             #pod $tester->configure_from_client_session($client_session);
834             #pod
835             #pod Given a client session object (like those stored in an Auth result), this
836             #pod reconfigures the testers access token, signing keys, URIs, and so forth. This
837             #pod method is used internally when logging in.
838             #pod
839             #pod =cut
840              
841             sub configure_from_client_session {
842 0     0 1   my ($self, $client_session) = @_;
843              
844             # It's not crazy to think that we'd also try to pull the primary accountId
845             # out of the accounts in the auth struct, but I don't think there's a lot to
846             # gain by doing that yet. Maybe later we'd use it to set the default
847             # X-JMAP-AccountId or other things, but I think there are too many open
848             # questions. I'm leaving it out on purpose for now. -- rjbs, 2016-11-18
849              
850             # This is no longer fatal because you might be an anonymous session that
851             # needs to call this to fetch an updated signing key. -- rjbs, 2017-03-23
852             # abort("no accessToken in client session object")
853             # unless $client_session->{accessToken};
854              
855 0           $self->_access_token($client_session->{accessToken});
856              
857 0 0 0       if ($client_session->{signingId} && $client_session->{signingKey}) {
858             $self->_jwt_config({
859             signingId => $client_session->{signingId},
860             signingKey => $client_session->{signingKey},
861             signingKeyValidUntil => $client_session->{signingKeyValidUntil},
862 0           });
863             } else {
864 0           $self->_jwt_config(undef);
865             }
866              
867 0           for my $type (qw(api download upload)) {
868 0 0         if (defined (my $uri = $client_session->{"${type}Url"})) {
869 0           my $setter = "$type\_uri";
870 0           $self->$setter($uri);
871             } else {
872 0           my $clearer = "clear_$type\_uri";
873 0           $self->$clearer;
874             }
875             }
876              
877 0           $self->_primary_accounts($client_session->{primaryAccounts});
878 0           $self->_accounts($client_session->{accounts});
879              
880 0           return;
881             }
882              
883             #pod =method logout
884             #pod
885             #pod $tester->logout;
886             #pod
887             #pod This method attempts to log out from the server by sending a C request
888             #pod to the authentication URI.
889             #pod
890             #pod This method respects the C attributes of the
891             #pod JMAP::Tester object, and in futures mode will return a future that will resolve
892             #pod to the Result.
893             #pod
894             #pod =cut
895              
896             sub logout {
897 0     0 1   my ($self) = @_;
898              
899             # This is fatal, not a failure return, because it reflects the user screwing
900             # up, not a possible JMAP-related condition. -- rjbs, 2017-02-10
901 0 0         Carp::confess("can't logout: no authentication_uri configured")
902             unless $self->has_authentication_uri;
903              
904 0           my $req = HTTP::Request->new(
905             DELETE => $self->authentication_uri,
906             [
907             'Content-Type' => 'application/json; charset=utf-8',
908             'Accept' => 'application/json',
909             ],
910             );
911              
912             my $future = $self->ua->request($self, $req, 'auth')->then(sub {
913 0     0     my ($res) = @_;
914              
915 0 0         if ($res->code == 204) {
916 0           $self->_access_token(undef);
917              
918 0           return Future->done(
919             JMAP::Tester::Result::Logout->new({
920             http_response => $res,
921             })
922             );
923             }
924              
925 0           return Future->fail(
926             JMAP::Tester::Result::Failure->new({
927             ident => "failed to log out",
928             http_response => $res,
929             })
930             );
931 0           });
932              
933 0 0         return $self->should_return_futures ? $future : $future->$Failsafe->get;
934             }
935              
936             #pod =method http_request
937             #pod
938             #pod my $response = $jtest->http_request($http_request);
939             #pod
940             #pod Sometimes, you may need to make an HTTP request with your existing web
941             #pod connection. This might be to interact with a custom authentication mechanism,
942             #pod to access custom endpoints, or just to make very, very specifically crafted
943             #pod requests. For this reasons, C exists.
944             #pod
945             #pod Pass this method an L and it will use the tester's UA object to
946             #pod make the request.
947             #pod
948             #pod This method respects the C attributes of the
949             #pod JMAP::Tester object, and in futures mode will return a future that will resolve
950             #pod to the L.
951             #pod
952             #pod =cut
953              
954             sub http_request {
955 0     0 1   my ($self, $http_request) = @_;
956              
957 0           my $future = $self->ua->request($self, $http_request, 'misc');
958 0 0         return $self->should_return_futures ? $future : $future->$Failsafe->get;
959             }
960              
961             #pod =method http_get
962             #pod
963             #pod my $response = $jtest->http_get($url, $headers);
964             #pod
965             #pod This method is just sugar for calling C to make a GET request for
966             #pod the given URL. C<$headers> is an optional arrayref of headers.
967             #pod
968             #pod =cut
969              
970             sub http_get {
971 0     0 1   my ($self, $url, $headers) = @_;
972              
973 0 0         my $req = HTTP::Request->new(
974             GET => $url,
975             (defined $headers ? $headers : ()),
976             );
977 0           return $self->http_request($req);
978             }
979              
980             #pod =method http_post
981             #pod
982             #pod my $response = $jtest->http_post($url, $body, $headers);
983             #pod
984             #pod This method is just sugar for calling C to make a POST request
985             #pod for the given URL. C<$headers> is an arrayref of headers and C<$body> is the
986             #pod byte string to be passed as the body.
987             #pod
988             #pod =cut
989              
990             sub http_post {
991 0     0 1   my ($self, $url, $body, $headers) = @_;
992              
993 0   0       my $req = HTTP::Request->new(
994             POST => $url,
995             $headers // [],
996             $body,
997             );
998              
999 0           return $self->http_request($req);
1000             }
1001              
1002             1;
1003              
1004             __END__