File Coverage

blib/lib/JMAP/Tester.pm
Criterion Covered Total %
statement 80 262 30.5
branch 3 86 3.4
condition 0 27 0.0
subroutine 25 50 50.0
pod 12 15 80.0
total 120 440 27.2


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