File Coverage

blib/lib/Net/Async/Matrix/Room.pm
Criterion Covered Total %
statement 212 379 55.9
branch 37 100 37.0
condition 30 84 35.7
subroutine 44 73 60.2
pod 23 24 95.8
total 346 660 52.4


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::Room;
7              
8 12     12   37 use strict;
  12         13  
  12         267  
9 12     12   38 use warnings;
  12         14  
  12         259  
10              
11             # Not really a Notifier but we like the ->maybe_invoke_event style
12 12     12   35 use base qw( IO::Async::Notifier );
  12         13  
  12         949  
13              
14             our $VERSION = '0.18_003';
15             $VERSION = eval $VERSION;
16              
17 12     12   44 use Carp;
  12         13  
  12         507  
18              
19 12     12   40 use Future;
  12         10  
  12         208  
20 12     12   39 use Future::Utils qw( repeat );
  12         10  
  12         413  
21              
22 12     12   45 use List::Util qw( pairmap );
  12         15  
  12         460  
23 12     12   36 use Time::HiRes qw( time );
  12         16  
  12         52  
24              
25 12     12   4989 use Net::Async::Matrix::Room::State;
  12         14  
  12         420  
26             # TEMPORARY hack
27             *Member = \&Net::Async::Matrix::Room::State::Member;
28              
29 12     12   46 use Data::Dump 'pp';
  12         13  
  12         415  
30              
31 12     12   39 use constant TYPING_RESEND_SECONDS => 30;
  12         102  
  12         41960  
32              
33             =head1 NAME
34              
35             C - a single Matrix room
36              
37             =head1 DESCRIPTION
38              
39             An instances in this class are used by L to represent a
40             single Matrix room.
41              
42             =cut
43              
44             =head1 EVENTS
45              
46             The following events are invoked, either using subclass methods or C
47             references in parameters:
48              
49             =head2 on_synced_state
50              
51             Invoked after the initial sync of the room has been completed as far as the
52             state.
53              
54             =head2 on_message $member, $content, $event
55              
56             =head2 on_back_message $member, $content, $event
57              
58             Invoked on receipt of a new message from the given member, either "live" from
59             the event stream, or from backward pagination.
60              
61             =head2 on_membership $member, $event, $subject_member, %changes
62              
63             =head2 on_back_membership $member, $event, $subject_member, %changes
64              
65             Invoked on receipt of a membership change event for the given member, either
66             "live" from the event stream, or from backward pagination. C<%changes> will be
67             a key/value list of state field names that were changed, whose values are
68             2-element ARRAY references containing the before/after values of those fields.
69              
70             on_membership: $field_name => [ $old_value, $new_value ]
71             on_back_membership: $field_name => [ $new_value, $old_value ]
72              
73             Note carefully that the second value in each array gives the "updated" value,
74             in the direction of the change - that is, for C it gives the
75             new value after the change but for C it gives the old value
76             before. Fields whose values did not change are not present in the C<%changes>
77             list; the values of these can be inspected on the C<$member> object.
78              
79             It is unspecified what values the C<$member> object has for fields present in
80             the change list - client code should not rely on these fields.
81              
82             In most cases when users change their own membership status (such as normal
83             join or leave), the C<$member> and C<$subject_member> parameters refer to the
84             same object. In other cases, such as invites or kicks, the C<$member>
85             parameter refers to the member performing the change, and the
86             C<$subject_member> refers to member that the change is about.
87              
88             =head2 on_state_changed $member, $event, %changes
89              
90             =head2 on_back_state_changed $member, $event, %changes
91              
92             Invoked on receipt of a change of room state (such as name or topic).
93              
94             In the special case of room aliases, because they are considered "state" but
95             are stored per-homeserver, the changes value will consist of three fields; the
96             old and new values I, and a list of the known aliases
97             from all the other servers:
98              
99             on_state_changed: aliases => [ $old, $new, $other ]
100             on_back_state_changed: aliases => [ $new, $old, $other ]
101              
102             This allows a client to detect deletions and additions by comparing the before
103             and after lists, while still having access to the full set of before or after
104             aliases, should it require it.
105              
106             =head2 on_presence $member, %changes
107              
108             Invoked when a member of the room changes membership or presence state. The
109             C<$member> object will already be in the new state. C<%changes> will be a
110             key/value list of state fields names that were changed, and references to
111             2-element ARRAYs containing the old and new values for this field.
112              
113             =head2 on_typing $member, $is_typing
114              
115             Invoked on receipt of a typing notification change, when the given member
116             either starts or stops typing.
117              
118             =head2 on_members_typing @members
119              
120             Invoked on receipt of a typing notification change to give the full set of
121             currently-typing members. This is invoked after the individual C
122             events.
123              
124             =head2 on_read_receipt $member, $event_id, $content
125              
126             Invoked on receipt of a C type of receipt message.
127              
128             =cut
129              
130             sub _init
131             {
132 7     7   59 my $self = shift;
133 7         9 my ( $params ) = @_;
134 7         29 $self->SUPER::_init( $params );
135              
136 7         32 $self->{matrix} = delete $params->{matrix};
137 7         13 $self->{room_id} = delete $params->{room_id};
138              
139             # Server gives us entire sets of typing user_ids all at once. We have to
140             # remember state
141 7         14 $self->{typing_members} = {};
142              
143 7         44 $self->{live_state} = Net::Async::Matrix::Room::State->new( $self );
144             }
145              
146             sub configure
147             {
148 10     10 1 1442 my $self = shift;
149 10         17 my %params = @_;
150              
151 10         26 foreach (qw( on_message on_back_message on_membership on_back_membership
152             on_presence on_synced_state on_state_changed on_back_state_changed
153             on_typing on_members_typing on_read_receipt )) {
154 110 100       161 $self->{$_} = delete $params{$_} if exists $params{$_};
155             }
156              
157 10         41 $self->SUPER::configure( %params );
158             }
159              
160             =head1 METHODS
161              
162             =cut
163              
164             # FUNCTION
165             sub _delete_null_changes
166             {
167 9     9   9 my ( $changes ) = @_;
168              
169 9         11 foreach ( keys %$changes ) {
170 12         8 my ( $old, $new ) = @{ $changes->{$_} };
  12         15  
171              
172 12 100 100     84 delete $changes->{$_} if !defined $old and !defined $new or
      66        
      100        
      66        
173             defined $old and defined $new and $old eq $new;
174             }
175             }
176              
177             # FUNCTION
178             sub _pushdown_changes
179             {
180 1     1   2 my ( $ch ) = @_;
181 1         1 my ( $oldhash, $newhash ) = @$ch;
182              
183 1         2 my %changes;
184              
185 1         2 foreach ( keys %$oldhash ) {
186 1         1 my $old = $oldhash->{$_};
187 1 50       3 if( !exists $newhash->{$_} ) {
188 0 0       0 $changes{$_} = [ $old, undef ] if defined $old;
189 0         0 next;
190             }
191              
192 1         2 my $new = $newhash->{$_};
193              
194 1 50 33     12 $changes{$_} = [ $old, $new ] unless !defined $old and !defined $new or
      33        
      33        
      33        
195             defined $old and defined $new and $old eq $new;
196             }
197              
198 1         3 foreach ( keys %$newhash ) {
199 1         1 my $new = $newhash->{$_};
200 1 50       7 next if exists $oldhash->{$_};
201              
202 0 0       0 $changes{$_} = [ undef, $new ] if defined $new;
203             }
204              
205 1 50       5 return keys %changes ? \%changes : undef;
206             }
207              
208             sub _do_GET_json
209             {
210 0     0   0 my $self = shift;
211 0         0 my ( $path, @args ) = @_;
212              
213 0         0 $self->{matrix}->_do_GET_json( "/rooms/$self->{room_id}" . $path, @args );
214             }
215              
216             sub _do_PUT_json
217             {
218 4     4   6 my $self = shift;
219 4         4 my ( $path, $content ) = @_;
220              
221 4         21 $self->{matrix}->_do_PUT_json( "/rooms/$self->{room_id}" . $path, $content );
222             }
223              
224             sub _do_POST_json
225             {
226 2     2   3 my $self = shift;
227 2         3 my ( $path, $content ) = @_;
228              
229 2         11 $self->{matrix}->_do_POST_json( "/rooms/$self->{room_id}" . $path, $content );
230             }
231              
232             =head2 await_synced
233              
234             $f = $room->await_synced
235              
236             Returns a L stored within the room that will complete (with no value)
237             once the room initial state sync has been completed. This completes just
238             I the C event.
239              
240             =cut
241              
242             sub _reset_for_sync
243             {
244 1     1   2 my $self = shift;
245              
246 1         2 undef $self->{synced_future};
247             }
248              
249             sub _incoming_sync_invite
250             {
251 0     0   0 my $self = shift;
252 0         0 my ( $sync ) = @_;
253 0         0 warn "TODO handle incoming sync data in invite state";
254             }
255              
256             sub _incoming_sync_join
257             {
258 16     16   18 my $self = shift;
259 16         13 my ( $sync ) = @_;
260              
261 16         31 my $initial = not $self->await_synced->is_done;
262              
263             # Toplevel fields for now I'm ignoring
264             # account_data
265             # unread_notifications
266              
267 16         812 my $live_state = $self->live_state;
268              
269 16 100 66     63 if( $sync->{state} and $sync->{state}{events} and @{ $sync->{state}{events} } ) {
  7   66     28  
270 5         6 foreach my $event ( @{ $sync->{state}{events} } ) {
  5         16  
271 11         28 $live_state->handle_event( $event );
272             }
273             }
274              
275 16         19 foreach my $event ( @{ $sync->{timeline}{events} } ) {
  16         32  
276 8 100       16 if( defined $event->{state_key} ) {
277 7         19 my $old_event = $live_state->get_event( $event->{type}, $event->{state_key} );
278 7         13 $live_state->handle_event( $event );
279 7         9 $self->_handle_state_event( $old_event, $event, $live_state );
280             }
281             else {
282 1         3 $self->_handle_event( forward => $event );
283             }
284             }
285              
286 16         125 foreach my $event ( @{ $sync->{ephemeral}{events} } ) {
  16         35  
287 1         3 $self->_handle_event( ephemeral => $event );
288             }
289              
290 16 100       58 if( $initial ) {
291 7         12 $self->await_synced->done;
292 7         482 $self->maybe_invoke_event( on_synced_state => );
293             }
294             }
295              
296             sub _incoming_sync_leave
297             {
298 0     0   0 my $self = shift;
299 0         0 my ( $sync ) = @_;
300             # don't care for now
301             }
302              
303             sub await_synced
304             {
305 30     30 1 896 my $self = shift;
306 30   66     135 return $self->{synced_future} //= $self->loop->new_future;
307             }
308              
309             =head2 live_state
310              
311             $state = $room->live_state
312              
313             Returns a L instance representing the current
314             live-tracking state of the room.
315              
316             This instance will mutate and change as new state events are received.
317              
318             =cut
319              
320             sub live_state
321             {
322 31     31 1 30 my $self = shift;
323 31         62 return $self->{live_state};
324             }
325              
326             sub _handle_state_event
327             {
328 7     7   4 my $self = shift;
329 7         7 my ( $old_event, $new_event, $state ) = @_;
330              
331 7         7 my $old_content = $old_event->{content};
332 7         8 my $new_content = $new_event->{content};
333              
334 7         6 my %changes;
335 7         20 $changes{$_}->[0] = $old_content->{$_} for keys %$old_content;
336 7         14 $changes{$_}->[1] = $new_content->{$_} for keys %$new_content;
337              
338 7   50     17 $_->[1] //= undef for values %changes; # Ensure deleted key values become undef
339              
340 7         11 _delete_null_changes \%changes;
341              
342 7         18 my $member = $state->member( $new_event->{sender} );
343              
344 7         39 my $type = $new_event->{type};
345              
346 7         22 $type =~ m/^m\.room\.(.*)$/;
347 7 50       31 my $method = $1 ? "_handle_state_event_" . join( "_", split m/\./, $1 ) : undef;
348              
349 7 100 66     48 if( $method and my $code = $self->can( $method ) ) {
350 4         10 $self->$code( $member, $new_event, $state, %changes );
351             }
352             else {
353 3         15 $self->maybe_invoke_event( on_state_changed =>
354             $member, $new_event, %changes
355             );
356             }
357             }
358              
359             sub _handle_event
360             {
361 2     2   3 my $self = shift;
362 2         3 my ( $direction, $event ) = @_;
363              
364 2 50       16 $event->{type} =~ m/^(m\.room\.)?(.*)$/ or return;
365              
366 2 100       6 my $base = $1 ? "_handle_roomevent_" : "_handle_event_";
367 2         10 my $method = $base . join( "_", split( m/\./, $2 ), $direction );
368              
369 2 50       10 if( my $code = $self->can( $method ) ) {
370 2         7 $code->( $self, $event );
371             }
372             else {
373 0         0 warn "TODO: $direction event $event->{type}\n";
374             }
375             }
376              
377             sub _handle_state_backward
378             {
379 0     0   0 my $self = shift;
380 0         0 my ( $field, $event ) = @_;
381              
382 0         0 my $newvalue = $event->{content}{$field};
383 0         0 my $oldvalue = $event->{prev_content}{$field};
384              
385             $self->maybe_invoke_event( on_back_state_changed =>
386 0         0 $self->{back_members_by_userid}{$event->{user_id}}, $event,
387             $field => [ $newvalue, $oldvalue ]
388             );
389             }
390              
391             =head2 room_id
392              
393             $id = $room->room_id
394              
395             Returns the opaque room ID string for the room. Usually this would not be
396             required, except for long-term persistence uniqueness purposes, or for
397             inclusion in direct protocol URLs.
398              
399             =cut
400              
401             sub room_id
402             {
403 1     1 1 493 my $self = shift;
404 1         4 return $self->{room_id};
405             }
406              
407             =head2 name
408              
409             $name = $room->name
410              
411             Returns the room name, if defined, otherwise the opaque room ID.
412              
413             =cut
414              
415             sub _handle_roomevent_name_backward
416             {
417 0     0   0 my $self = shift;
418 0         0 my ( $event ) = @_;
419 0         0 $self->_handle_state_backward( name => $event );
420             }
421              
422             sub name
423             {
424 2     2 1 11 my $self = shift;
425 2   33     3 return $self->live_state->name || $self->room_id;
426             }
427              
428             =head2 set_name
429              
430             $room->set_name( $name )->get
431              
432             Requests to set a new room name.
433              
434             =cut
435              
436             sub set_name
437             {
438 0     0 1 0 my $self = shift;
439 0         0 my ( $name ) = @_;
440              
441 0         0 $self->_do_PUT_json( "/state/m.room.name", { name => $name } )
442             ->then_done();
443             }
444              
445             =head2 aliases
446              
447             @aliases = $room->aliases
448              
449             Returns a list of all the known room alias names taken from the
450             C events. Note that these are simply names I to have
451             aliases from the alias events; a client ought to still check that these are
452             valid before presenting them to the user as such, or in other ways relying on
453             their values.
454              
455             =cut
456              
457             sub _handle_state_event_aliases
458             {
459 1     1   1 my $self = shift;
460 1         2 my ( $member, $event, $state, %changes ) = @_;
461              
462 1         2 my $homeserver = $event->{state_key};
463              
464 0         0 my @others = map { $_->{content}{aliases} }
465 1         4 grep { $_->{state_key} ne $homeserver }
466 1         2 values %{ $state->get_events( "m.room.aliases" ) };
  1         2  
467              
468 1         6 $changes{aliases}[2] = \@others;
469              
470 1         3 $self->maybe_invoke_event( on_state_changed =>
471             $member, $event, %changes
472             );
473             }
474              
475             sub _handle_roomevent_aliases_backward
476             {
477 0     0   0 my $self = shift;
478 0         0 my ( $event ) = @_;
479              
480 0         0 my $homeserver = $event->{state_key};
481              
482 0   0     0 my $new = $event->{prev_content}{aliases} // [];
483 0   0     0 my $old = $event->{content}{aliases} // [];
484              
485 0         0 $self->{back_aliases_by_hs}{$homeserver} = [ @$new ];
486              
487 0         0 my @others = map { @{ $self->{back_aliases_by_hs}{$_} } }
  0         0  
488 0         0 grep { $_ ne $homeserver }
489 0         0 keys %{ $self->{back_aliases_by_hs} };
  0         0  
490              
491             $self->maybe_invoke_event( on_back_state_changed =>
492 0         0 $self->{back_members_by_userid}{$event->{user_id}}, $event,
493             aliases => [ $old, $new, \@others ]
494             );
495             }
496              
497             sub aliases
498             {
499 2     2 1 1414 my $self = shift;
500 2         5 return $self->live_state->aliases;
501             }
502              
503             =head2 join_rule
504              
505             $rule = $room->join_rule
506              
507             Returns the current C for the room; a string giving the type of
508             access new members may get:
509              
510             =over 4
511              
512             =item * public
513              
514             Any user may join without further permission
515              
516             =item * invite
517              
518             Users may only join if explicitly invited
519              
520             =item * knock
521              
522             Any user may send a knock message to request access; may only join if invited
523              
524             =item * private
525              
526             No new users may join the room
527              
528             =back
529              
530             =cut
531              
532             sub _handle_roomevent_join_rules_backward
533             {
534 0     0   0 my $self = shift;
535 0         0 my ( $event ) = @_;
536 0         0 $self->_handle_state_backward( join_rule => $event );
537             }
538              
539             sub join_rule
540             {
541 2     2 1 1566 my $self = shift;
542 2         5 return $self->live_state->join_rule;
543             }
544              
545             =head2 topic
546              
547             $topic = $room->topic
548              
549             Returns the room topic, if defined
550              
551             =cut
552              
553             sub _handle_roomevent_topic_backward
554             {
555 0     0   0 my $self = shift;
556 0         0 my ( $event ) = @_;
557 0         0 $self->_handle_state_backward( topic => $event );
558             }
559              
560             sub topic
561             {
562 2     2 1 1328 my $self = shift;
563 2         5 return $self->live_state->topic;
564             }
565              
566             =head2 set_topic
567              
568             $room->set_topic( $topic )->get
569              
570             Requests to set a new room topic.
571              
572             =cut
573              
574             sub set_topic
575             {
576 0     0 1 0 my $self = shift;
577 0         0 my ( $topic ) = @_;
578              
579 0         0 $self->_do_PUT_json( "/state/m.room.topic", { topic => $topic } )
580             ->then_done();
581             }
582              
583             =head2 levels
584              
585             %levels = $room->levels
586              
587             Returns a key/value list of the room levels; that is, the member power level
588             required to perform each of the named actions.
589              
590             =cut
591              
592             sub _handle_generic_level
593             {
594 0     0   0 my $self = shift;
595 0         0 my ( $phase, $level, $convert, $event ) = @_;
596              
597 0         0 foreach my $k (qw( content prev_content )) {
598 0 0       0 next unless my $levels = $event->{$k};
599              
600             $event->{$k} = {
601 0         0 map { $convert->{$_} => $levels->{$_} } keys %$convert
  0         0  
602             };
603             }
604              
605 0 0       0 if( $phase eq "initial" ) {
    0          
    0          
606 0         0 my $levels = $event->{content};
607              
608 0         0 $self->{levels}{$_} = $levels->{$_} for keys %$levels;
609             }
610             elsif( $phase eq "forward" ) {
611 0         0 my $newlevels = $event->{content};
612 0         0 my $oldlevels = $event->{prev_content};
613              
614 0         0 my %changes;
615 0         0 foreach ( keys %$newlevels ) {
616 0         0 $self->{levels}{$_} = $newlevels->{$_};
617              
618             $changes{"level.$_"} = [ $oldlevels->{$_}, $newlevels->{$_} ]
619 0 0 0     0 if !defined $oldlevels->{$_} or $oldlevels->{$_} != $newlevels->{$_};
620             }
621              
622 0         0 my $member = $self->member( $event->{sender} );
623 0         0 $self->maybe_invoke_event( on_state_changed =>
624             $member, $event, %changes
625             );
626             }
627             elsif( $phase eq "backward" ) {
628 0         0 my $newlevels = $event->{content};
629 0         0 my $oldlevels = $event->{prev_content};
630              
631 0         0 my %changes;
632 0         0 foreach ( keys %$newlevels ) {
633             $changes{"level.$_"} = [ $newlevels->{$_}, $oldlevels->{$_} ]
634 0 0 0     0 if !defined $oldlevels->{$_} or $oldlevels->{$_} != $newlevels->{$_};
635             }
636              
637 0         0 my $member = $self->{back_members_by_userid}{$event->{user_id}};
638 0         0 $self->maybe_invoke_event( on_back_state_changed =>
639             $member, $event, %changes
640             );
641             }
642             }
643              
644             sub levels
645             {
646 0     0 1 0 my $self = shift;
647 0         0 return %{ $self->{levels} };
  0         0  
648             }
649              
650             =head2 change_levels
651              
652             $room->change_levels( %levels )->get
653              
654             Performs a room levels change, submitting new values for the given keys while
655             leaving other keys unchanged.
656              
657             =cut
658              
659             sub change_levels
660             {
661 0     0 1 0 my $self = shift;
662 0         0 my %levels = @_;
663              
664             # Delete null changes
665 0         0 foreach ( keys %levels ) {
666 0 0       0 delete $levels{$_} if $self->{levels}{$_} == $levels{$_};
667             }
668              
669 0         0 my %events;
670              
671             # These go in their own event with the content key 'level'
672 0         0 foreach (qw( send_event add_state )) {
673 0 0       0 $events{"${_}_level"} = { level => $levels{$_} } if exists $levels{$_};
674             }
675              
676             # These go in an 'ops_levels' event
677 0         0 foreach (qw( ban kick redact )) {
678 0 0       0 $events{ops_levels}{"${_}_level"} = $levels{$_} if exists $levels{$_};
679             }
680              
681             # Fill in remaining 'ops_levels' keys
682 0 0       0 if( $events{ops_levels} ) {
683 0   0     0 $events{ops_levels}{"${_}_level"} //= $self->{levels}{$_} for qw( ban kick redact );
684             }
685              
686             Future->needs_all(
687 0         0 map { $self->_do_PUT_json( "/state/m.room.$_", $events{$_} ) } keys %events
  0         0  
688             )->then_done();
689             }
690              
691             =head2 members
692              
693             @members = $room->members
694              
695             Returns a list of member structs containing the currently known members of the
696             room, in no particular order. This list will include users who are not yet
697             members of the room, but simply have been invited.
698              
699             =cut
700              
701             sub _handle_roomevent_member_backward
702             {
703 0     0   0 my $self = shift;
704 0         0 my ( $event ) = @_;
705              
706             # $self->_handle_roomevent_member( on_back_membership => $event,
707             # $self->{back_members_by_userid}, $event->{content}, $event->{prev_content} );
708             }
709              
710             sub _handle_state_event_member
711             {
712 2     2   3 my $self = shift;
713 2         4 my ( $member, $event, $state, %changes ) = @_;
714              
715             # Currently, the server "deletes" users from the room by setting their
716             # membership to "leave". It's neater if we consider an empty content in
717             # that case.
718 2         4 foreach my $idx ( 0, 1 ) {
719 4 50 100     15 next unless ( $changes{membership}[$idx] // "" ) eq "leave";
720              
721 0         0 undef $changes{$_}[$idx] for keys %changes;
722             }
723              
724 2         3 my $user_id = $event->{state_key}; # == user the change applies to
725              
726 2 50 0     5 my $target_member = $state->member( $user_id ) or
727             warn "ARGH: roomevent_member with unknown user id '$user_id'" and return;
728              
729 2         39 _delete_null_changes \%changes;
730              
731 2         7 $self->maybe_invoke_event( on_membership => $member, $event, $target_member, %changes );
732             }
733              
734             sub members
735             {
736 3     3 1 1803 my $self = shift;
737 3         6 return $self->live_state->members;
738             }
739              
740             sub member
741             {
742 2     2 0 4 my $self = shift;
743 2         2 my ( $user_id ) = @_;
744 2         3 return $self->live_state->member( $user_id );
745             }
746              
747             =head2 joined_members
748              
749             @members = $room->joined_members
750              
751             Returns the subset of C who actually in the C<"join"> state -
752             i.e. are not invitees, or have left.
753              
754             =cut
755              
756             sub joined_members
757             {
758 0     0 1 0 my $self = shift;
759 0   0     0 return grep { ( $_->membership // "" ) eq "join" } $self->members;
  0         0  
760             }
761              
762             =head2 member_level
763              
764             $level = $room->member_level( $user_id )
765              
766             Returns the current cached value for the power level of the given user ID, or
767             the default value if no specific value exists for the given ID.
768              
769             =cut
770              
771             sub _handle_roomevent_power_levels_backward
772             {
773 0     0   0 my $self = shift;
774 0         0 my ( $event ) = @_;
775              
776             # $self->_handle_roomevent_power_levels( on_back_membership =>
777             # $event, $self->{back_members_by_userid}, $event->{content}, $event->{prev_content}
778             # );
779             }
780              
781             sub _handle_state_event_power_levels
782             {
783 1     1   2 my $self = shift;
784 1         2 my ( $member, $event, $state, %changes ) = @_;
785              
786             # Before we go any further we should also clean up null changes in 'users'
787             # and 'events' hashes by pushing the 'old+new' diff ARRAYrefs down into the
788             # hashes
789 1   66     6 $_ and $_ = _pushdown_changes $_ for $changes{users}, $changes{events};
790              
791 1 50       3 if( my $users = $changes{users} ) {
792             # TODO: handle default changes
793 1         2 my $default = $event->{content}{user_default};
794              
795 1         2 foreach my $user_id ( keys %$users ) {
796 1 50       3 my $target = $state->member( $user_id ) or next;
797 1         12 my ( $oldlevel, $newlevel ) = @{ $users->{$user_id} };
  1         2  
798              
799 1   33     2 $oldlevel //= $default;
800 1   33     2 $newlevel //= $default;
801              
802 1         5 $self->maybe_invoke_event( on_membership =>
803             $member, $event, $target, level => [ $oldlevel, $newlevel ]
804             );
805             }
806             }
807             }
808              
809             sub member_level
810             {
811 2     2 1 2413 my $self = shift;
812 2         2 my ( $user_id ) = @_;
813 2         5 return $self->live_state->member_level( $user_id );
814             }
815              
816             =head2 change_member_levels
817              
818             $room->change_member_levels( %levels )->get
819              
820             Performs a member power level change, submitting new values for user IDs to
821             the home server. As there is no server API to make individual mutations, this
822             is done by taking the currently cached values, applying the changes given by
823             the C<%levels> key/value list, and submitting the resulting whole as the new
824             value for the C room state.
825              
826             The C<%levels> key/value list should provide new values for keys giving user
827             IDs, or the special user ID of C to change the overall default value
828             for users not otherwise mentioned. Setting the special value of C for a
829             user ID will remove that ID from the set, reverting them to the default.
830              
831             =cut
832              
833             sub change_member_levels
834             {
835 0     0 1 0 my $self = shift;
836              
837             # Can't just edit the local cache as maybe the server will reject it. Clone
838             # it and if the server accepts our modification the cache will be updated
839             # on the incoming event.
840              
841 0         0 my %user_levels = %{ $self->{powerlevels}{users} };
  0         0  
842              
843 0         0 while( @_ ) {
844 0         0 my $user_id = shift;
845 0         0 my $value = shift;
846              
847 0 0       0 if( defined $value ) {
848 0         0 $user_levels{$user_id} = $value;
849             }
850             else {
851 0         0 delete $user_levels{$user_id};
852             }
853             }
854              
855             $self->_do_PUT_json( "/state/m.room.power_levels",
856 0         0 { %{ $self->{powerlevels} }, users => \%user_levels }
  0         0  
857             )->then_done();
858             }
859              
860             =head2 leave
861              
862             $room->leave->get
863              
864             Requests to leave the room. After this completes, the user will no longer be
865             a member of the room.
866              
867             =cut
868              
869             sub leave
870             {
871 0     0 1 0 my $self = shift;
872 0         0 $self->_do_POST_json( "/leave", {} );
873             }
874              
875             =head2 invite
876              
877             $room->invite( $user_id )->get
878              
879             Sends an invitation for the user with the given User ID to join the room.
880              
881             =cut
882              
883             sub invite
884             {
885 0     0 1 0 my $self = shift;
886 0         0 my ( $user_id ) = @_;
887              
888 0         0 $self->_do_POST_json( "/invite", { user_id => $user_id } )
889             ->then_done();
890             }
891              
892             =head2 send_message
893              
894             $event_id = $room->send_message( %args )->get
895              
896             Sends a new message to the room. Requires a C named argument giving the
897             message type. Depending on the type, further keys will be required that
898             specify the message contents:
899              
900             =over 4
901              
902             =item m.text, m.emote, m.notice
903              
904             Require C
905              
906             =item m.image, m.audio, m.video, m.file
907              
908             Require C
909              
910             =item m.location
911              
912             Require C
913              
914             =back
915              
916             If an additional argument called C is provided, this is used as the
917             transaction ID for the message, which is then sent as a C request instead
918             of a C.
919              
920             $event_id = $room->send_message( $text )->get
921              
922             A convenient shortcut to sending an C message with a body string and
923             no additional content.
924              
925             =cut
926              
927             my %MSG_REQUIRED_FIELDS = (
928             'm.text' => [qw( body )],
929             'm.emote' => [qw( body )],
930             'm.notice' => [qw( body )],
931             'm.image' => [qw( url )],
932             'm.audio' => [qw( url )],
933             'm.video' => [qw( url )],
934             'm.file' => [qw( url )],
935             'm.location' => [qw( geo_uri )],
936             );
937              
938             sub send_message
939             {
940 2     2 1 1117 my $self = shift;
941 2 50       10 my %args = ( @_ == 1 ) ? ( type => "m.text", body => shift ) : @_;
942              
943             my $type = $args{msgtype} = delete $args{type} or
944 2 50       6 croak "Require a 'type' field";
945              
946 2 50       6 $MSG_REQUIRED_FIELDS{$type} or
947             croak "Unrecognised message type '$type'";
948              
949 2         1 foreach (@{ $MSG_REQUIRED_FIELDS{$type} } ) {
  2         5  
950 2 50       4 $args{$_} or croak "'$type' messages require a '$_' field";
951             }
952              
953 2 100       5 if( defined( my $txn_id = $args{txn_id} ) ) {
954             $self->_do_PUT_json( "/send/m.room.message/$txn_id", \%args )->then( sub {
955 1     1   74 my ( $response ) = @_;
956 1         4 Future->done( $response->{event_id} );
957 1         5 });
958             }
959             else {
960             $self->_do_POST_json( "/send/m.room.message", \%args )->then( sub {
961 1     1   109 my ( $response ) = @_;
962 1         5 Future->done( $response->{event_id} );
963 1         4 });
964             }
965             }
966              
967             =head2 paginate_messages
968              
969             $room->paginate_messages( limit => $n )->get
970              
971             Requests more messages of back-pagination history.
972              
973             There is no need to maintain a reference on the returned C; it will be
974             adopted by the room object.
975              
976             =cut
977              
978             sub paginate_messages
979             {
980 0     0 1 0 my $self = shift;
981 0         0 my %args = @_;
982              
983 0   0     0 my $limit = $args{limit} // 20;
984 0   0     0 my $from = $self->{pagination_token} // "END";
985              
986 0 0       0 croak "Cannot paginate_messages any further since we're already at the start"
987             if $from eq "START";
988              
989             # Since we're now doing pagination, we'll need a second set of member
990             # objects
991             $self->{back_members_by_userid} //= {
992 0   0 0   0 pairmap { $a => Member( $b->user, $b->displayname, $b->membership ) } %{ $self->{members_by_userid} }
  0         0  
  0         0  
993             };
994             $self->{back_aliases_by_hs} //= {
995 0   0 0   0 pairmap { $a => [ @$b ] } %{ $self->{aliases_by_hs} }
  0         0  
  0         0  
996             };
997              
998             my $f = $self->_do_GET_json( "/messages",
999             from => $from,
1000             dir => "b",
1001             limit => $limit,
1002             )->then( sub {
1003 0     0   0 my ( $response ) = @_;
1004              
1005 0         0 foreach my $event ( @{ $response->{chunk} } ) {
  0         0  
1006 0 0       0 next unless my ( $subtype ) = ( $event->{type} =~ m/^m\.room\.(.*)$/ );
1007 0         0 $subtype =~ s/\./_/g;
1008              
1009 0 0       0 if( my $code = $self->can( "_handle_roomevent_${subtype}_backward" ) ) {
1010 0         0 $code->( $self, $event );
1011             }
1012             else {
1013 0         0 $self->{matrix}->log( "TODO: Handle room pagination event $subtype" );
1014             }
1015             }
1016              
1017 0         0 $self->{pagination_token} = $response->{end};
1018 0         0 Future->done( $self );
1019 0         0 });
1020 0         0 $self->adopt_future( $f );
1021             }
1022              
1023             =head2 typing_start
1024              
1025             $room->typing_start
1026              
1027             Sends a typing notification that the user is currently typing in this room.
1028             This notification will periodically be re-sent as required by the protocol
1029             until the C method is called.
1030              
1031             =cut
1032              
1033             sub typing_start
1034             {
1035 1     1 1 270 my $self = shift;
1036              
1037 1 50       3 return if $self->{typing_timer};
1038              
1039 1         4 my $user_id = $self->{matrix}->myself->user_id;
1040              
1041             my $f = $self->{typing_timer} = repeat {
1042             $self->_do_PUT_json( "/typing/$user_id", {
1043             typing => 1,
1044             timeout => ( TYPING_RESEND_SECONDS + 5 ) * 1000, # msec
1045             })->then( sub {
1046 2         195 $self->{matrix}->{make_delay}->( TYPING_RESEND_SECONDS );
1047 2     2   44 });
1048 1     1   61 } while => sub { !shift->failure };
  1         416  
1049              
1050             $f->on_fail( $self->_capture_weakself( sub {
1051 0     0   0 my $self = shift;
1052 0         0 $self->invoke_error( @_ );
1053 1         92 }));
1054             }
1055              
1056             =head2 typing_stop
1057              
1058             $room->typing_stop
1059              
1060             Sends a typing notification that the user is no longer typing in this room.
1061             This method also cancels the repeating re-send behaviour created by
1062             C.
1063              
1064             =cut
1065              
1066             sub typing_stop
1067             {
1068 1     1 1 39 my $self = shift;
1069              
1070 1 50       4 return unless my $f = $self->{typing_timer};
1071              
1072 1         2 $f->cancel;
1073 1         70 undef $self->{typing_timer};
1074              
1075 1         4 my $user_id = $self->{matrix}->myself->user_id;
1076              
1077 1         12 $self->adopt_future(
1078             $self->_do_PUT_json( "/typing/$user_id", {
1079             typing => 0,
1080             })
1081             );
1082             }
1083              
1084             =head2 send_read_receipt
1085              
1086             $room->send_read_receipt( event_id => $event_id, ... )->get
1087              
1088             Sends a C receipt to the given room for the given event ID.
1089              
1090             =cut
1091              
1092             sub send_read_receipt
1093             {
1094 1     1 1 2496 my $self = shift;
1095 1         3 my %args = @_;
1096              
1097 1 50       3 my $event_id = $args{event_id} or croak "Require event_id";
1098              
1099 1         5 $self->_do_POST_json( "/receipt/m.read/$event_id", {} );
1100             }
1101              
1102             sub _handle_roomevent_create_forward
1103             {
1104 0     0   0 my $self = shift;
1105 0         0 my ( $event ) = @_;
1106              
1107             # Nothing interesting here...
1108             }
1109             *_handle_roomevent_create_initial = \&_handle_roomevent_create_forward;
1110              
1111             sub _handle_roomevent_create_backward
1112             {
1113 0     0   0 my $self = shift;
1114              
1115             # Stop now
1116 0         0 $self->{pagination_token} = "START";
1117             }
1118              
1119             sub _handle_roomevent_message_forward
1120             {
1121 1     1   1 my $self = shift;
1122 1         1 my ( $event ) = @_;
1123              
1124 1         2 my $user_id = $event->{sender};
1125 1 50 0     4 my $member = $self->member( $user_id ) or
1126             warn "TODO: Unknown member '$user_id' for forward message" and return;
1127              
1128 1         34 $self->maybe_invoke_event( on_message => $member, $event->{content}, $event );
1129             }
1130              
1131             sub _handle_roomevent_message_backward
1132             {
1133 0     0   0 my $self = shift;
1134 0         0 my ( $event ) = @_;
1135              
1136 0         0 my $user_id = $event->{user_id};
1137 0 0 0     0 my $member = $self->{back_members_by_userid}{$user_id} or
1138             warn "TODO: Unknown member '$user_id' for backward message" and return;
1139              
1140 0         0 $self->maybe_invoke_event( on_back_message => $member, $event->{content}, $event );
1141             }
1142              
1143             sub _handle_event_m_presence
1144             {
1145 0     0   0 my $self = shift;
1146 0         0 my ( $user, %changes ) = @_;
1147 0 0       0 my $member = $self->member( $user->user_id ) or return;
1148              
1149             $changes{$_} and $member->$_ = $changes{$_}[1]
1150 0   0     0 for qw( displayname );
1151              
1152 0         0 $self->maybe_invoke_event( on_presence => $member, %changes );
1153             }
1154              
1155             sub _handle_event_m_typing_ephemeral
1156             {
1157 0     0   0 my $self = shift;
1158 0         0 my ( $event ) = @_;
1159              
1160 0         0 my $typing = $self->{typing_members};
1161 0         0 my %not_typing = %$typing;
1162              
1163 0         0 foreach my $user_id ( @{ $event->{content}{user_ids} } ) {
  0         0  
1164 0         0 delete $not_typing{$user_id};
1165 0 0       0 next if $typing->{$user_id};
1166              
1167 0         0 $typing->{$user_id}++;
1168 0 0       0 my $member = $self->member( $user_id ) or next;
1169 0         0 $self->maybe_invoke_event( on_typing => $member, 1 );
1170             }
1171              
1172 0         0 foreach my $user_id ( keys %not_typing ) {
1173 0 0       0 my $member = $self->member( $user_id ) or next;
1174 0         0 $self->maybe_invoke_event( on_typing => $member, 0 );
1175 0         0 delete $typing->{$user_id};
1176             }
1177              
1178 0         0 my @members = map { $self->member( $_ ) } keys %$typing;
  0         0  
1179 0         0 $self->maybe_invoke_event( on_members_typing => grep { defined } @members );
  0         0  
1180             }
1181              
1182             sub _handle_event_m_receipt_ephemeral
1183             {
1184 1     1   1 my $self = shift;
1185 1         2 my ( $event ) = @_;
1186              
1187 1         1 my $content = $event->{content};
1188 1         3 foreach my $event_id ( keys %$content ) {
1189 1         1 my $receipt = $content->{$event_id};
1190 1 50       3 my $read_receipt = $receipt->{"m.read"} or next;
1191              
1192 1         1 foreach my $user_id ( keys %$read_receipt ) {
1193 1         2 my $content = $read_receipt->{$user_id};
1194 1 50       2 my $member = $self->member( $user_id ) or next;
1195              
1196 1         35 $self->maybe_invoke_event( on_read_receipt => $member, $event_id, $content );
1197             }
1198             }
1199             }
1200              
1201             =head1 MEMBERSHIP STRUCTURES
1202              
1203             Parameters documented as C<$member> receive a membership struct, which
1204             supports the following methods:
1205              
1206             =head2 $user = $member->user
1207              
1208             User object of the member.
1209              
1210             =head2 $displayname = $member->displayname
1211              
1212             Profile displayname of the user.
1213              
1214             =head2 $membership = $member->membership
1215              
1216             Membership state. One of C or C.
1217              
1218             =head1 AUTHOR
1219              
1220             Paul Evans
1221              
1222             =cut
1223              
1224             0x55AA;