File Coverage

blib/lib/Net/Async/Matrix.pm
Criterion Covered Total %
statement 257 388 66.2
branch 42 96 43.7
condition 22 59 37.2
subroutine 58 86 67.4
pod 18 26 69.2
total 397 655 60.6


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2014-2016 -- leonerd@leonerd.org.uk
5              
6             package Net::Async::Matrix;
7              
8 12     12   1319269 use strict;
  12         20  
  12         282  
9 12     12   46 use warnings;
  12         12  
  12         307  
10              
11 12     12   45 use base qw( IO::Async::Notifier );
  12         16  
  12         5229  
12             IO::Async::Notifier->VERSION( '0.63' ); # adopt_future
13              
14             our $VERSION = '0.18_003';
15             $VERSION = eval $VERSION;
16              
17 12     12   38056 use Carp;
  12         18  
  12         515  
18              
19 12     12   46 use Future;
  12         15  
  12         211  
20 12     12   4683 use Future::Utils qw( repeat );
  12         18296  
  12         601  
21 12     12   415 use JSON::MaybeXS qw( encode_json decode_json );
  12         4219  
  12         468  
22              
23 12     12   4604 use Data::Dump 'pp';
  12         43643  
  12         625  
24 12     12   4656 use File::stat;
  12         54562  
  12         36  
25 12     12   725 use List::Util 1.29 qw( pairmap );
  12         226  
  12         863  
26 12     12   46 use Scalar::Util qw( blessed );
  12         13  
  12         369  
27 12     12   4382 use Struct::Dumb;
  12         12725  
  12         48  
28 12     12   511 use Time::HiRes qw( time );
  12         14  
  12         79  
29 12     12   1394 use URI;
  12         3137  
  12         368  
30              
31             struct User => [qw( user_id displayname presence last_active )];
32              
33 12     12   4772 use Net::Async::Matrix::Room;
  12         17  
  12         341  
34              
35 12     12   52 use constant PATH_PREFIX => "/_matrix/client/r0";
  12         12  
  12         567  
36 12     12   42 use constant LONGPOLL_TIMEOUT => 30;
  12         11  
  12         536  
37              
38             # This is only needed for the (undocumented) recaptcha bypass feature
39 12     12   41 use constant HAVE_DIGEST_HMAC_SHA1 => eval { require Digest::HMAC_SHA1; };
  12         14  
  12         13  
  12         4183  
40              
41             =head1 NAME
42              
43             C - use Matrix with L
44              
45             =head1 SYNOPSIS
46              
47             use Net::Async::Matrix;
48             use IO::Async::Loop;
49              
50             my $loop = IO::Async::Loop->new;
51              
52             my $matrix = Net::Async::Matrix->new(
53             server => "my.home.server",
54             );
55              
56             $loop->add( $matrix );
57              
58             $matrix->login(
59             user_id => '@my-user:home.server',
60             password => 'SeKr1t',
61             )->get;
62              
63             =head1 DESCRIPTION
64              
65             F is an new open standard for interoperable Instant Messaging and VoIP,
66             providing pragmatic HTTP APIs and open source reference implementations for
67             creating and running your own real-time communication infrastructure.
68              
69             This module allows an program to interact with a Matrix homeserver as a
70             connected user client.
71              
72             L
73              
74             =cut
75              
76             =head1 EVENTS
77              
78             The following events are invoked, either using subclass methods or C
79             references in parameters:
80              
81             =head2 on_log $message
82              
83             A request to write a debugging log message. This is provided temporarily for
84             development and debugging purposes, but will at some point be removed when the
85             code has reached a certain level of stability.
86              
87             =head2 on_presence $user, %changes
88              
89             Invoked on receipt of a user presence change event from the homeserver.
90             C<%changes> will map user state field names to 2-element ARRAY references,
91             each containing the old and new values of that field.
92              
93             =head2 on_room_new $room
94              
95             Invoked when a new room first becomes known about.
96              
97             Passed an instance of L.
98              
99             =head2 on_room_del $room
100              
101             Invoked when the user has now left a room.
102              
103             =head2 on_invite $event
104              
105             Invoked on receipt of a room invite. The C<$event> will contain the plain
106             Matrix event as received; with at least the keys C and C.
107              
108             =head2 on_unknown_event $event
109              
110             Invoked on receipt of any sort of event from the event stream, that is not
111             recognised by any of the other code. This can be used to handle new kinds of
112             incoming events.
113              
114             =cut
115              
116             =head1 PARAMETERS
117              
118             The following named parameters may be passed to C or C. In
119             addition, C references for event handlers using the event names listed
120             above can also be given.
121              
122             =head2 server => STRING
123              
124             Hostname and port number to contact the homeserver at. Given in the form
125              
126             $hostname:$port
127              
128             This string will be interpolated directly into HTTP request URLs.
129              
130             =head2 SSL => BOOL
131              
132             Whether to use SSL/TLS to communicate with the homeserver. Defaults false.
133              
134             =head2 SSL_* => ...
135              
136             Any other parameters whose names begin C will be stored for passing to
137             the HTTP user agent. See L for more detail.
138              
139             =head2 path_prefix => STRING
140              
141             Optional. Gives the path prefix to find the Matrix client API at. Normally
142             this should not need modification.
143              
144             =head2 on_room_member, on_room_message => CODE
145              
146             Optional. Sets default event handlers on new room objects.
147              
148             =head2 enable_events => BOOL
149              
150             Optional. Normally enabled, but if set to a defined-but-false value (i.e. 0 or
151             empty string) the event stream will be disabled. This will cause none of the
152             incoming event handlers to be invoked, because the server will not be polled
153             for events.
154              
155             This may be useful in simple send-only cases where the client has no interest
156             in receiveing any events, and wishes to reduce the load on the homeserver.
157              
158             =head2 longpoll_timeout => NUM
159              
160             Optional. Timeout in seconds for the C longpoll operation. Defaults
161             to 30 seconds if not supplied.
162              
163             =head2 first_sync_limit => NUM
164              
165             Optional. Number of events per room to fetch on the first C request on
166             startup. Defaults to the server's builtin value if not defined, which is
167             likely to be 10.
168              
169             =cut
170              
171             sub _init
172             {
173 11     11   1289 my $self = shift;
174 11         18 my ( $params ) = @_;
175              
176 11         68 $self->SUPER::_init( $params );
177              
178 11   33     75 $params->{ua} ||= do {
179 0         0 require Net::Async::HTTP;
180 0         0 Net::Async::HTTP->VERSION( '0.36' ); # SSL params
181 0         0 my $ua = Net::Async::HTTP->new(
182             fail_on_error => 1,
183             max_connections_per_host => 3, # allow 2 longpolls + 1 actual command
184             user_agent => __PACKAGE__,
185             pipeline => 0,
186             );
187 0         0 $self->add_child( $ua );
188 0         0 $ua
189             };
190              
191             # Injectable for unit tests, other event systems, etc..
192             # For now undocumented while I try to work out the wider design issues
193             $self->{make_delay} = delete $params->{make_delay} || $self->_capture_weakself( sub {
194 1     1   8 my ( $self, $secs ) = @_;
195 1         4 $self->loop->delay_future( after => $secs );
196 11   66     66 } );
197              
198 11         36 $self->{msgid_next} = 0;
199              
200 11         26 $self->{users_by_id} = {};
201 11         21 $self->{rooms_by_id} = {};
202              
203 11         23 $self->{path_prefix} = PATH_PREFIX;
204              
205 11         25 $self->{longpoll_timeout} = LONGPOLL_TIMEOUT;
206             }
207              
208             =head1 METHODS
209              
210             The following methods documented with a trailing call to C<< ->get >> return
211             L instances.
212              
213             =cut
214              
215             sub configure
216             {
217 26     26 1 341 my $self = shift;
218 26         51 my %params = @_;
219              
220 26         54 foreach (qw( server path_prefix ua SSL enable_events longpoll_timeout
221             first_sync_limit
222             on_log on_unknown_event on_presence on_room_new on_room_del on_invite
223             on_room_member on_room_message )) {
224 390 100       541 $self->{$_} = delete $params{$_} if exists $params{$_};
225             }
226              
227 26         45 my $ua = $self->{ua};
228 26         56 foreach ( grep { m/^SSL_/ } keys %params ) {
  14         49  
229 0         0 $ua->configure( $_ => delete $params{$_} );
230             }
231              
232 26         98 $self->SUPER::configure( %params );
233             }
234              
235             sub log
236             {
237 0     0 0 0 my $self = shift;
238 0         0 my ( $message ) = @_;
239              
240 0 0       0 $self->{on_log}->( $message ) if $self->{on_log};
241             }
242              
243             sub _maybe_encode
244             {
245 114     114   97 my $v = shift;
246 114 100 66     450 return $v if !ref $v or blessed $v;
247 1 50       4 return $v if ref $v ne "HASH";
248 1         27 return encode_json( $v );
249             }
250              
251             sub _uri_for_path
252             {
253 57     57   54 my $self = shift;
254 57         71 my ( $path, %params ) = @_;
255              
256 57 100       199 $path = "/$path" unless $path =~ m{^/};
257              
258 57         203 my $uri = URI->new;
259 57 50       41529 $uri->scheme( $self->{SSL} ? "https" : "http" );
260 57         27317 $uri->authority( $self->{server} );
261 57         1579 $uri->path( $self->{path_prefix} . $path );
262              
263 57 50       1210 $params{access_token} = $self->{access_token} if defined $self->{access_token};
264              
265             # Some parameter values can be JSON-encoded objects
266 57     114   437 $uri->query_form( pairmap { $a => _maybe_encode $b } %params );
  114         161  
267              
268 57         3165 return $uri;
269             }
270              
271             sub _do_GET_json
272             {
273 43     43   40 my $self = shift;
274 43         73 my ( $path, %params ) = @_;
275              
276             $self->{ua}->GET( $self->_uri_for_path( $path, %params ) )->then( sub {
277 29     29   16584 my ( $response ) = @_;
278              
279 29 50       169 $response->content_type eq "application/json" or
280             return Future->fail( "Expected application/json response", matrix => );
281              
282 29         991 Future->done( decode_json( $response->content ), $response );
283 43         96 });
284             }
285              
286             sub _do_send_json
287             {
288 13     13   15 my $self = shift;
289 13         16 my ( $method, $path, $content ) = @_;
290              
291 13         27 my $req = HTTP::Request->new( $method, $self->_uri_for_path( $path ) );
292 13         502 $req->content( encode_json( $content ) );
293 13         179 $req->header( Content_length => length $req->content ); # ugh
294              
295 13         591 $req->header( Content_type => "application/json" );
296              
297             my $f = $self->{ua}->do_request(
298             request => $req,
299             )->then( sub {
300 13     13   14926 my ( $response ) = @_;
301              
302 13 50       72 $response->content_type eq "application/json" or
303             return Future->fail( "Expected application/json response", matrix => );
304              
305 13         277 my $content = $response->content;
306 13 50 33     168 if( length $content and $content ne q("") ) {
307 13 50       20 eval {
308 13         51 $content = decode_json( $content );
309 13         39 1;
310             } or
311             return Future->fail( "Unable to parse JSON response $content" );
312 13         36 return Future->done( $content, $response );
313             }
314             else {
315             # server yields empty strings sometimes... :/
316 0         0 return Future->done( undef, $response );
317             }
318 13         336 });
319              
320 13         828 return $self->adopt_future( $f );
321             }
322              
323 4     4   9 sub _do_PUT_json { shift->_do_send_json( PUT => @_ ) }
324 9     9   27 sub _do_POST_json { shift->_do_send_json( POST => @_ ) }
325              
326             sub _do_DELETE
327             {
328 0     0   0 my $self = shift;
329 0         0 my ( $path, %params ) = @_;
330              
331             $self->{ua}->do_request(
332 0         0 method => "DELETE",
333             uri => $self->_uri_for_path( $path, %params ),
334             );
335             }
336              
337             sub _do_POST_file
338             {
339 1     1   1 my $self = shift;
340 1         3 my ( $path, %params ) = @_;
341              
342 1         2 my $uri = $self->_uri_for_path( "" );
343 1         3 $uri->path( "/_matrix" . $path );
344              
345 1         19 my $req = HTTP::Request->new( "POST" , $uri );
346 1         39 $req->header( Content_type => $params{content_type} );
347              
348 1         39 my $body;
349              
350 1 50 0     3 if( defined $params{content} ) {
    0          
351 1         5 $req->content( $params{content} );
352 1         16 $req->header( Content_length => length $req->content );
353             }
354             elsif( defined $params{file} or defined $params{fh} ) {
355 0         0 my $fh = $params{fh};
356             $fh or open $fh, "<", $params{file} or
357 0 0 0     0 return Future->fail( "Cannot read $params{file} - $!", open => );
358              
359             $body = sub {
360 0 0   0   0 $fh->read( my $buffer, 65536 ) or return undef;
361 0         0 return $buffer;
362 0         0 };
363              
364 0   0     0 $req->header( Content_length => $params{content_length} // ( stat $fh )->size );
365             }
366              
367             my $f = $self->{ua}->do_request(
368             request => $req,
369             request_body => $body,
370             )->then( sub {
371 1     1   3098 my ( $response ) = @_;
372 1 50       3 $response->content_type eq "application/json" or
373             return Future->fail( "Expected application/json response", matrix => );
374              
375 1         22 my $content = $response->content;
376 1         6 my $uri;
377 1 50 33     6 if( length $content and $content ne q("") ) {
378 1 50       2 eval {
379 1         4 $content = decode_json( $content );
380 1         3 1;
381             } or
382             return Future->fail( "Unable to parse JSON response " );
383 1         3 return Future->done( $content, $response );
384             }
385             else {
386 0         0 return Future->done( undef, $response );
387             }
388 1         34 });
389              
390 1         68 return $self->adopt_future( $f );
391             }
392              
393             =head2 login
394              
395             $matrix->login( %params )->get
396              
397             Performs the necessary steps required to authenticate with the configured
398             Home Server, actually obtain an access token and starting the event stream
399             (unless disabled by the C option being false). The returned
400             C will eventually yield the C<$matrix> object itself, so it can be
401             easily chained.
402              
403             There are various methods of logging in supported by Matrix; the following
404             sets of arguments determine which is used:
405              
406             =over 4
407              
408             =item user_id, password
409              
410             Log in via the C method.
411              
412             =item user_id, access_token
413              
414             Directly sets the C and C fields, bypassing the usual
415             login semantics. This presumes you already have an existing access token to
416             re-use, obtained by some other mechanism. This exists largely for testing
417             purposes.
418              
419             =back
420              
421             =cut
422              
423             sub login
424             {
425 14     14 1 37286 my $self = shift;
426 14         48 my %params = @_;
427              
428 14 100 66     95 if( defined $params{user_id} and defined $params{access_token} ) {
429 13         57 $self->{$_} = $params{$_} for qw( user_id access_token );
430 13         54 $self->configure( notifier_name => "uid=$params{user_id}" );
431             return ( ( $self->{enable_events} // 1 ) ? $self->start : Future->done )->then( sub {
432 12     12   8283 Future->done( $self )
433 13 100 100     224 });
434             }
435              
436             # Otherwise; try to obtain the login flow information
437             $self->_do_GET_json( "/login" )->then( sub {
438 1     1   66 my ( $response ) = @_;
439 1         2 my $flows = $response->{flows};
440              
441 1         1 my @supported;
442 1         2 foreach my $flow ( @$flows ) {
443 1 50       10 next unless my ( $type ) = $flow->{type} =~ m/^m\.login\.(.*)$/;
444 1         2 push @supported, $type;
445              
446 1 50       10 next unless my $code = $self->can( "_login_with_$type" );
447 1 50       4 next unless my $f = $code->( $self, %params );
448              
449 1         69 return $f;
450             }
451              
452 0         0 Future->fail( "Unsure how to log in (server supports @supported)", matrix => );
453 1         3 });
454             }
455              
456             sub _login_with_password
457             {
458 1     1   1 my $self = shift;
459 1         2 my %params = @_;
460              
461 1 50 33     7 return unless defined $params{user_id} and defined $params{password};
462              
463             $self->_do_POST_json( "/login",
464             { type => "m.login.password", user => $params{user_id}, password => $params{password} }
465             )->then( sub {
466 1     1   79 my ( $resp ) = @_;
467 1 50       7 return $self->login( %$resp, %params ) if defined $resp->{access_token};
468 0         0 return Future->fail( "Expected server to respond with 'access_token'", matrix => );
469 1         6 });
470             }
471              
472             =head2 register
473              
474             $matrix->register( %params )->get
475              
476             Performs the necessary steps required to create a new account on the
477             configured Home Server.
478              
479             =cut
480              
481             sub register
482             {
483 0     0 1 0 my $self = shift;
484 0         0 my %params = @_;
485              
486             $self->_do_GET_json( "/register" )->then( sub {
487 0     0   0 my ( $response ) = @_;
488 0         0 my $flows = $response->{flows};
489              
490 0         0 my @supported;
491             # Try to find a flow for which we can support all the stages
492 0         0 FLOW: foreach my $flow ( @$flows ) {
493             # Might or might not find a 'stages' key
494 0 0       0 my @stages = $flow->{stages} ? @{ $flow->{stages} } : ( $flow->{type} );
  0         0  
495              
496 0         0 push @supported, join ",", @stages;
497              
498 0         0 my @flowcode;
499 0         0 foreach my $stage ( @stages ) {
500 0 0       0 next FLOW unless my ( $type ) = $stage =~ m/^m\.login\.(.*)$/;
501 0         0 $type =~ s/\./_/g;
502              
503 0 0       0 next FLOW unless my $method = $self->can( "_register_with_$type" );
504 0 0       0 next FLOW unless my $code = $method->( $self, %params );
505              
506 0         0 push @flowcode, $code;
507             }
508              
509             # If we've got this far then we know we can implement all the stages
510 0         0 my $start = Future->new;
511 0         0 my $tail = $start;
512 0         0 $tail = $tail->then( $_ ) for @flowcode;
513              
514 0         0 $start->done();
515             return $tail->then( sub {
516 0         0 my ( $resp ) = @_;
517 0 0       0 return $self->login( %$resp ) if defined $resp->{access_token};
518 0         0 return Future->fail( "Expected server to respond with 'access_token'", matrix => );
519 0         0 });
520             }
521              
522 0         0 Future->fail( "Unsure how to register (server supports @supported)", matrix => );
523 0         0 });
524             }
525              
526             sub _register_with_password
527             {
528 0     0   0 my $self = shift;
529 0         0 my %params = @_;
530              
531 0 0       0 return unless defined( my $password = $params{password} );
532              
533             return sub {
534 0     0   0 my ( $resp ) = @_;
535              
536             $self->_do_POST_json( "/register", {
537             type => "m.login.password",
538             session => $resp->{session},
539              
540             user => $params{user_id},
541 0         0 password => $password,
542             } );
543             }
544 0         0 }
545              
546             sub _register_with_recaptcha
547             {
548 0     0   0 my $self = shift;
549 0         0 my %params = @_;
550              
551             return unless defined( my $secret = $params{captcha_bypass_secret} ) and
552 0 0 0     0 defined $params{user_id};
553              
554 0         0 warn "Cannot use captcha_bypass_secret to bypass m.register.recaptcha without Digest::HMAC_SHA1\n" and return
555             if !HAVE_DIGEST_HMAC_SHA1;
556              
557 0         0 my $digest = Digest::HMAC_SHA1::hmac_sha1_hex( $params{user_id}, $secret );
558              
559             return sub {
560 0     0   0 my ( $resp ) = @_;
561              
562             $self->_do_POST_json( "/register", {
563             type => "m.login.recaptcha",
564             session => $resp->{session},
565              
566             user => $params{user_id},
567 0         0 captcha_bypass_hmac => $digest,
568             } );
569 0         0 };
570             }
571              
572             =head2 sync
573              
574             $matrix->sync( %params )->get
575              
576             Performs a single C request on the server, returning the raw results
577             directly.
578              
579             Takes the following named parameters
580              
581             =over 4
582              
583             =item since => STRING
584              
585             Optional. Sync token from the previous request.
586              
587             =back
588              
589             =cut
590              
591             sub sync
592             {
593 42     42 1 3727 my $self = shift;
594 42         84 my ( %params ) = @_;
595              
596 42         120 $self->_do_GET_json( "/sync", %params );
597             }
598              
599             sub await_synced
600             {
601 12     12 0 18 my $self = shift;
602 12   33     61 return $self->{synced_future} //= $self->loop->new_future;
603             }
604              
605             =head2 start
606              
607             $f = $matrix->start
608              
609             Performs the initial sync on the server, and starts the event stream to
610             begin receiving events.
611              
612             While this method does return a C it is not required that the caller
613             keep track of this; the object itself will store it. It will complete when the
614             initial sync has fininshed, and the event stream has started.
615              
616             If the initial sync has already been requested, this method simply returns the
617             future it returned the last time, ensuring that you can await the client
618             starting up simply by calling it; it will not start a second time.
619              
620             =cut
621              
622             sub start
623             {
624 16     16 1 1993 my $self = shift;
625              
626 16 50       42 defined $self->{access_token} or croak "Cannot ->start without an access token";
627              
628 16   66     56 return $self->{start_f} ||= do {
629 14         33 undef $self->{synced_future};
630              
631 14         16 foreach my $room ( values %{ $self->{rooms_by_id} } ) {
  14         42  
632 1         4 $room->_reset_for_sync;
633             }
634              
635 14         18 my %first_sync_args;
636              
637             $first_sync_args{filter}{room}{timeline}{limit} = $self->{first_sync_limit}
638 14 100       42 if defined $self->{first_sync_limit};
639              
640             $self->sync( %first_sync_args )->then( sub {
641 12     12   1141 my ( $sync ) = @_;
642              
643 12         45 $self->_incoming_sync( $sync );
644              
645 12         46 $self->start_longpoll( since => $sync->{next_batch} );
646              
647 12         260 return $self->await_synced->done;
648 14     1   48 })->on_fail( sub { undef $self->{start_f} });
  1         179  
649             };
650             }
651              
652             =head2 stop
653              
654             $matrix->stop
655              
656             Stops the event stream. After calling this you will need to use C again
657             to continue receiving events.
658              
659             =cut
660              
661             sub stop
662             {
663 4     4 1 2313 my $self = shift;
664              
665 4 50       24 ( delete $self->{start_f} )->cancel if $self->{start_f};
666 4         18 $self->stop_longpoll;
667             }
668              
669             ## Longpoll events
670              
671             sub start_longpoll
672             {
673 12     12 0 19 my $self = shift;
674 12         28 my %args = @_;
675              
676 12         37 $self->stop_longpoll;
677 12         22 $self->{longpoll_last_token} = $args{since};
678              
679             my $f = $self->{longpoll_f} = repeat {
680 28     28   555 my $last_token = $self->{longpoll_last_token};
681              
682             Future->wait_any(
683             $self->{make_delay}->( $self->{longpoll_timeout} + 5 )
684             ->else_fail( "Longpoll timed out" ),
685              
686             $self->sync(
687             since => $last_token,
688             timeout => $self->{longpoll_timeout} * 1000, # msec
689             )->then( sub {
690 16         1148 my ( $sync ) = @_;
691              
692 16         37 $self->_incoming_sync( $sync );
693              
694 16         22 $self->{longpoll_last_token} = $sync->{next_batch};
695              
696 16         38 Future->done();
697             }),
698             )->else( sub {
699 0         0 my ( $failure ) = @_;
700 0         0 warn "Longpoll failed - $failure\n";
701              
702 0         0 $self->{make_delay}->( 3 )
703 28         82 });
704 12     16   120 } while => sub { !shift->failure };
  16         2591  
705              
706             # Don't ->adopt_future this one as it makes it hard to grab to cancel it
707             # again, but apply the same on_fail => invoke_error logic
708             $f->on_fail( $self->_capture_weakself( sub {
709 0     0   0 my $self = shift;
710 0         0 $self->invoke_error( @_ );
711 12         3293 }));
712             }
713              
714             sub stop_longpoll
715             {
716 16     16 0 46 my $self = shift;
717              
718 16 100       275 ( delete $self->{longpoll_f} )->cancel if $self->{longpoll_f};
719             }
720              
721             sub _get_or_make_user
722             {
723 20     20   14 my $self = shift;
724 20         18 my ( $user_id ) = @_;
725              
726 20   66     75 return $self->{users_by_id}{$user_id} ||= User( $user_id, undef, undef, undef );
727             }
728              
729             sub _make_room
730             {
731 7     7   8 my $self = shift;
732 7         10 my ( $room_id ) = @_;
733              
734 7 50       26 $self->{rooms_by_id}{$room_id} and
735             croak "Already have a room with ID '$room_id'";
736              
737 7         8 my @args;
738 7         14 foreach (qw( message member )) {
739 14 50       46 push @args, "on_$_" => $self->{"on_room_$_"} if $self->{"on_room_$_"};
740             }
741              
742 7         28 my $room = $self->{rooms_by_id}{$room_id} = $self->make_room(
743             matrix => $self,
744             room_id => $room_id,
745             @args,
746             );
747 7         130 $self->add_child( $room );
748              
749 7         379 $self->maybe_invoke_event( on_room_new => $room );
750              
751 7         114 return $room;
752             }
753              
754             sub make_room
755             {
756 7     7 1 10 my $self = shift;
757 7         64 return Net::Async::Matrix::Room->new( @_ );
758             }
759              
760             sub _get_or_make_room
761             {
762 16     16   16 my $self = shift;
763 16         18 my ( $room_id ) = @_;
764              
765 16   66     75 return $self->{rooms_by_id}{$room_id} //
766             $self->_make_room( $room_id );
767             }
768              
769             =head2 myself
770              
771             $user = $matrix->myself
772              
773             Returns the user object representing the connected user.
774              
775             =cut
776              
777             sub myself
778             {
779 2     2 1 2 my $self = shift;
780 2         5 return $self->_get_or_make_user( $self->{user_id} );
781             }
782              
783             =head2 user
784              
785             $user = $matrix->user( $user_id )
786              
787             Returns the user object representing a user of the given ID, if defined, or
788             C.
789              
790             =cut
791              
792             sub user
793             {
794 0     0 1 0 my $self = shift;
795 0         0 my ( $user_id ) = @_;
796 0         0 return $self->{users_by_id}{$user_id};
797             }
798              
799             sub _incoming_sync
800             {
801 28     28   33 my $self = shift;
802 28         35 my ( $sync ) = @_;
803              
804 28         40 foreach my $category (qw( invite join leave )) {
805 84 100       256 my $rooms = $sync->{rooms}{$category} or next;
806 16         40 foreach my $room_id ( keys %$rooms ) {
807 16         27 my $roomsync = $rooms->{$room_id};
808              
809 16         26 my $room = $self->_get_or_make_room( $room_id );
810              
811 16         19 $room->${\"_incoming_sync_$category"}( $roomsync );
  16         99  
812             }
813             }
814              
815 28         33 foreach my $event ( @{ $sync->{presence}{events} } ) {
  28         69  
816 1         3 $self->_handle_event_m_presence( $event );
817             }
818              
819             # TODO: account_data
820             }
821              
822             sub _on_self_leave
823             {
824 0     0   0 my $self = shift;
825 0         0 my ( $room ) = @_;
826              
827 0         0 $self->maybe_invoke_event( on_room_del => $room );
828              
829 0         0 delete $self->{rooms_by_id}{$room->room_id};
830             }
831              
832             =head2 get_displayname
833              
834             =head2 set_displayname
835              
836             $name = $matrix->get_displayname->get
837              
838             $matrix->set_displayname( $name )->get
839              
840             Accessor and mutator for the user account's "display name" profile field.
841              
842             =cut
843              
844             sub get_displayname
845             {
846 0     0 1 0 my $self = shift;
847 0         0 my ( $user_id ) = @_;
848              
849 0   0     0 $user_id //= $self->{user_id};
850              
851             $self->_do_GET_json( "/profile/$user_id/displayname" )->then( sub {
852 0     0   0 my ( $content ) = @_;
853              
854 0         0 Future->done( $content->{displayname} );
855 0         0 });
856             }
857              
858             sub set_displayname
859             {
860 0     0 1 0 my $self = shift;
861 0         0 my ( $name ) = @_;
862              
863 0         0 $self->_do_PUT_json( "/profile/$self->{user_id}/displayname",
864             { displayname => $name }
865             );
866             }
867              
868             =head2 get_presence
869              
870             =head2 set_presence
871              
872             ( $presence, $msg ) = $matrix->get_presence->get
873              
874             $matrix->set_presence( $presence, $msg )->get
875              
876             Accessor and mutator for the user's current presence state and optional status
877             message string.
878              
879             =cut
880              
881             sub get_presence
882             {
883 0     0 1 0 my $self = shift;
884              
885             $self->_do_GET_json( "/presence/$self->{user_id}/status" )->then( sub {
886 0     0   0 my ( $status ) = @_;
887 0         0 Future->done( $status->{presence}, $status->{status_msg} );
888 0         0 });
889             }
890              
891             sub set_presence
892             {
893 0     0 1 0 my $self = shift;
894 0         0 my ( $presence, $msg ) = @_;
895              
896 0         0 my $status = {
897             presence => $presence,
898             };
899 0 0       0 $status->{status_msg} = $msg if defined $msg;
900              
901 0         0 $self->_do_PUT_json( "/presence/$self->{user_id}/status", $status )
902             }
903              
904             sub get_presence_list
905             {
906 0     0 0 0 my $self = shift;
907              
908             $self->_do_GET_json( "/presence_list/$self->{user_id}" )->then( sub {
909 0     0   0 my ( $events ) = @_;
910              
911 0         0 my @users;
912 0         0 foreach my $event ( @$events ) {
913 0         0 my $user = $self->_get_or_make_user( $event->{user_id} );
914 0         0 foreach (qw( presence displayname )) {
915 0 0       0 $user->$_ = $event->{$_} if defined $event->{$_};
916             }
917              
918 0         0 push @users, $user;
919             }
920              
921 0         0 Future->done( @users );
922 0         0 });
923             }
924              
925             sub invite_presence
926             {
927 0     0 0 0 my $self = shift;
928 0         0 my ( $remote ) = @_;
929              
930 0         0 $self->_do_POST_json( "/presence_list/$self->{user_id}",
931             { invite => [ $remote ] }
932             );
933             }
934              
935             sub drop_presence
936             {
937 0     0 0 0 my $self = shift;
938 0         0 my ( $remote ) = @_;
939              
940 0         0 $self->_do_POST_json( "/presence_list/$self->{user_id}",
941             { drop => [ $remote ] }
942             );
943             }
944              
945             =head2 create_room
946              
947             ( $room, $room_alias ) = $matrix->create_room( $alias_localpart )->get
948              
949             Requests the creation of a new room and associates a new alias with the given
950             localpart on the server. The returned C will return an instance of
951             L and a string containing the full alias that was
952             created.
953              
954             =cut
955              
956             sub create_room
957             {
958 0     0 1 0 my $self = shift;
959 0         0 my ( $room_alias ) = @_;
960              
961 0         0 my $body = {};
962 0 0       0 $body->{room_alias_name} = $room_alias if defined $room_alias;
963             # TODO: visibility?
964              
965             $self->_do_POST_json( "/createRoom", $body )->then( sub {
966 0     0   0 my ( $content ) = @_;
967              
968 0         0 my $room = $self->_get_or_make_room( $content->{room_id} );
969             $room->initial_sync
970 0         0 ->then_done( $room, $content->{room_alias} );
971 0         0 });
972             }
973              
974             =head2 join_room
975              
976             $room = $matrix->join_room( $room_alias_or_id )->get
977              
978             Requests to join an existing room with the given alias name or plain room ID.
979             If this room is already known by the C<$matrix> object, this method simply
980             returns it.
981              
982             =cut
983              
984             sub join_room
985             {
986 6     6 1 634 my $self = shift;
987 6         9 my ( $room_alias ) = @_;
988              
989             $self->_do_POST_json( "/join/$room_alias", {} )->then( sub {
990 6     6   484 my ( $content ) = @_;
991 6         14 my $room_id = $content->{room_id};
992              
993 6 50       17 if( my $room = $self->{rooms_by_id}{$room_id} ) {
994 0         0 return Future->done( $room );
995             }
996             else {
997 6         23 my $room = $self->_make_room( $room_id );
998 6         33 return $room->await_synced->then_done( $room );
999             }
1000 6         29 });
1001             }
1002              
1003             sub room_list
1004             {
1005 0     0 0 0 my $self = shift;
1006              
1007             $self->_do_GET_json( "/users/$self->{user_id}/rooms/list" )
1008             ->then( sub {
1009 0     0   0 my ( $response ) = @_;
1010 0         0 Future->done( pp($response) );
1011 0         0 });
1012             }
1013              
1014             =head2 add_alias
1015              
1016             =head2 delete_alias
1017              
1018             $matrix->add_alias( $alias, $room_id )->get
1019              
1020             $matrix->delete_alias( $alias )->get
1021              
1022             Performs a directory server request to create the given room alias name, to
1023             point at the room ID, or to remove it again.
1024              
1025             Note that this is likely only to be supported for alias names scoped within
1026             the homeserver the client is connected to, and that additionally some form of
1027             permissions system may be in effect on the server to limit access to the
1028             directory server.
1029              
1030             =cut
1031              
1032             sub add_alias
1033             {
1034 0     0 1 0 my $self = shift;
1035 0         0 my ( $alias, $room_id ) = @_;
1036              
1037 0         0 $self->_do_PUT_json( "/directory/room/$alias",
1038             { room_id => $room_id },
1039             )->then_done();
1040             }
1041              
1042             sub delete_alias
1043             {
1044 0     0 1 0 my $self = shift;
1045 0         0 my ( $alias ) = @_;
1046              
1047 0         0 $self->_do_DELETE( "/directory/room/$alias" )
1048             ->then_done();
1049             }
1050              
1051             =head2 upload
1052              
1053             $content_uri = $matrix->upload( %params )->get
1054              
1055             Performs a post to the server's media content repository, to upload a new
1056             piece of content, returning the content URI that points to it.
1057              
1058             The content can be specified in any of three ways, with the following three
1059             mutually-exclusive arguments:
1060              
1061             =over 4
1062              
1063             =item content => STRING
1064              
1065             Gives the content directly as an immediate scalar value.
1066              
1067             =item file => STRING
1068              
1069             Gives the path to a readable file on the filesystem containing the content.
1070              
1071             =item fh => IO
1072              
1073             Gives an opened IO handle the content can be read from.
1074              
1075             =back
1076              
1077             The following additional arguments are also recognised:
1078              
1079             =over 4
1080              
1081             =item content_type => STRING
1082              
1083             Gives the MIME type of the content data.
1084              
1085             =item content_length => INT
1086              
1087             Optional. If the content is being delivered from an opened filehandle (via the
1088             C argument), this gives the total length in bytes. This is required in
1089             cases such as reading from pipes, when the length of the content isn't
1090             immediately available such as by Cing the filehandle.
1091              
1092             =back
1093              
1094             =cut
1095              
1096             sub upload
1097             {
1098 1     1 1 89 my $self = shift;
1099 1         3 my %params = @_;
1100              
1101             defined $params{content_type} or
1102 1 50       4 croak "Require 'content_type'";
1103              
1104             defined $params{content} or defined $params{file} or defined $params{fh} or
1105 1 0 33     5 croak "Require 'content', 'file' or 'fh'";
      33        
1106              
1107             # This one takes ~full URL paths
1108             $self->_do_POST_file( "/media/v1/upload", %params )->then( sub {
1109 1     1   80 my ( $content, $response ) = @_;
1110 1         4 Future->done( $content->{content_uri} );
1111 1         5 });
1112             }
1113              
1114             ## Incoming events
1115              
1116             sub _handle_event_m_presence
1117             {
1118 1     1   1 my $self = shift;
1119 1         1 my ( $event ) = @_;
1120 1         2 my $content = $event->{content};
1121              
1122 1         3 my $user = $self->_get_or_make_user( $event->{sender} );
1123              
1124 1         30 my %changes;
1125 1         3 foreach (qw( presence displayname )) {
1126 2 100       8 next unless defined $content->{$_};
1127 1 50 33     4 next if defined $user->$_ and $content->{$_} eq $user->$_;
1128              
1129 1         8 $changes{$_} = [ $user->$_, $content->{$_} ];
1130 1         5 $user->$_ = $content->{$_};
1131             }
1132              
1133 1 50       3 if( defined $content->{last_active_ago} ) {
1134 0         0 my $new_last_active = time() - ( $content->{last_active_ago} / 1000 );
1135              
1136 0         0 $changes{last_active} = [ $user->last_active, $new_last_active ];
1137 0         0 $user->last_active = $new_last_active;
1138             }
1139              
1140             $self->maybe_invoke_event(
1141 1         8 on_presence => $user, %changes
1142             );
1143              
1144 1         17 foreach my $room ( values %{ $self->{rooms_by_id} } ) {
  1         4  
1145 0           $room->_handle_event_m_presence( $user, %changes );
1146             }
1147             }
1148              
1149             =head1 USER STRUCTURES
1150              
1151             Parameters documented as C<$user> receive a user struct, which supports the
1152             following methods:
1153              
1154             =head2 $user_id = $user->user_id
1155              
1156             User ID of the user.
1157              
1158             =head2 $displayname = $user->displayname
1159              
1160             Profile displayname of the user.
1161              
1162             =head2 $presence = $user->presence
1163              
1164             Presence state. One of C, C or C.
1165              
1166             =head2 $last_active = $user->last_active
1167              
1168             Epoch time that the user was last active.
1169              
1170             =cut
1171              
1172             =head1 SUBCLASSING METHODS
1173              
1174             The following methods are not normally required by users of this class, but
1175             are provided for the convenience of subclasses to override.
1176              
1177             =head2 $room = $matrix->make_room( %params )
1178              
1179             Returns a new instance of L.
1180              
1181             =cut
1182              
1183             =head1 SEE ALSO
1184              
1185             =over 4
1186              
1187             =item *
1188              
1189             L - matrix.org home page
1190              
1191             =item *
1192              
1193             L - matrix.org on github
1194              
1195             =back
1196              
1197             =cut
1198              
1199             =head1 AUTHOR
1200              
1201             Paul Evans
1202              
1203             =cut
1204              
1205             0x55AA;