File Coverage

blib/lib/Tangence/Server.pm
Criterion Covered Total %
statement 259 264 98.1
branch 23 40 57.5
condition 4 4 100.0
subroutine 40 40 100.0
pod 4 21 19.0
total 330 369 89.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, 2011-2021 -- leonerd@leonerd.org.uk
5              
6             package Tangence::Server 0.28;
7              
8 9     9   26332 use v5.26;
  9         30  
9 9     9   44 use warnings;
  9         11  
  9         240  
10 9     9   43 use experimental 'signatures';
  9         25  
  9         60  
11              
12 9     9   940 use base qw( Tangence::Stream );
  9         15  
  9         3632  
13              
14 9     9   81 use Carp;
  9         16  
  9         543  
15              
16 9     9   48 use Scalar::Util qw( weaken );
  9         15  
  9         426  
17 9     9   50 use Sub::Util 1.40 qw( set_subname );
  9         173  
  9         363  
18 9     9   56 use Feature::Compat::Try;
  9         20  
  9         64  
19              
20 9     9   845 use Tangence::Constants;
  9         26  
  9         1454  
21 9     9   55 use Tangence::Types;
  9         22  
  9         493  
22 9     9   3926 use Tangence::Server::Context;
  9         19  
  9         302  
23              
24 9     9   58 use Struct::Dumb;
  9         15  
  9         75  
25             struct CursorObject => [qw( cursor obj )];
26              
27             # We will accept any version back to 3
28 9     9   705 use constant VERSION_MINOR_MIN => 3;
  9         15  
  9         36274  
29              
30             =head1 NAME
31              
32             C - mixin class for building a C server
33              
34             =head1 SYNOPSIS
35              
36             This class is a mixin, it cannot be directly constructed
37              
38             package Example::Server;
39             use base qw( Base::Server Tangence::Server );
40              
41             sub new
42             {
43             my $class = shift;
44             my %args = @_;
45              
46             my $registry = delete $args{registry};
47              
48             my $self = $class->SUPER::new( %args );
49              
50             $self->registry( $registry );
51              
52             return $self;
53             }
54              
55             sub tangence_write
56             {
57             my $self = shift;
58             $self->write( $_[0] );
59             }
60              
61             sub on_read
62             {
63             my $self = shift;
64             $self->tangence_readfrom( $_[0] );
65             }
66              
67             =head1 DESCRIPTION
68              
69             This module provides mixin to implement a C server connection. It
70             should be mixed in to an object used to represent a single connection from a
71             client. It provides a location for the objects in server to store information
72             about the client connection, and coordinates passing messages between the
73             client and the objects in the server.
74              
75             This is a subclass of L which provides implementations of
76             the required C methods. A class mixing in C
77             must still provide the C method required for sending data to the
78             client.
79              
80             For an example of a class that uses this mixin, see
81             L.
82              
83             =cut
84              
85             =head1 PROVIDED METHODS
86              
87             The following methods are provided by this mixin.
88              
89             =cut
90              
91 9   100 9 0 49 sub subscriptions { shift->{subscriptions} ||= [] }
92 49   100 49 0 348 sub watches { shift->{watches} ||= [] }
93              
94             =head2 registry
95              
96             $server->registry( $registry )
97              
98             $registry = $server->registry
99              
100             Accessor to set or obtain the L object for the server.
101              
102             =cut
103              
104             sub registry
105             {
106 75     75 1 1052 my $self = shift;
107 75 100       199 $self->{registry} = shift if @_;
108 75         347 return $self->{registry};
109             }
110              
111             sub tangence_closed
112             {
113 1     1 1 1472 my $self = shift;
114 1         15 $self->SUPER::tangence_closed;
115              
116 1 50       10 if( my $subscriptions = $self->subscriptions ) {
117 1         4 foreach my $s ( @$subscriptions ) {
118 0         0 my ( $object, $event, $id ) = @$s;
119 0         0 $object->unsubscribe_event( $event, $id );
120             }
121              
122 1         2 undef @$subscriptions;
123             }
124              
125 1 50       3 if( my $watches = $self->watches ) {
126 1         3 foreach my $w ( @$watches ) {
127 4         8 my ( $object, $prop, $id ) = @$w;
128 4         11 $object->unwatch_property( $prop, $id );
129             }
130              
131 1         4 undef @$watches;
132             }
133              
134 1 50       15 if( my $cursors = $self->peer_hascursor ) {
135 1         8 foreach my $cursorobj ( values %$cursors ) {
136 0         0 $self->drop_cursorobj( $cursorobj );
137             }
138             }
139             }
140              
141 54         89 sub get_by_id ( $self, $id )
142 54     54 0 203 {
  54         77  
  54         67  
143             # Only permit the client to interact with objects they've already been
144             # sent, so they cannot gain access by inventing object IDs
145 54 100       156 $self->peer_hasobj->{$id} or
146             die "Access not allowed to object with id $id\n";
147              
148 48 50       141 my $obj = $self->registry->get_by_id( $id ) or
149             die "No such object with id $id\n";
150              
151 48         94 return $obj;
152             }
153              
154 4         6 sub handle_request_CALL ( $self, $token, $message )
  4         5  
155 4     4 0 9 {
  4         7  
  4         5  
156 4         22 my $ctx = Tangence::Server::Context->new( $self, $token );
157              
158 4         32 my $response;
159             try {
160             my $objid = $message->unpack_int();
161              
162             my $object = $self->get_by_id( $objid );
163              
164             $response = $object->handle_request_CALL( $ctx, $message );
165             }
166 4         182 catch ( $e ) {
167             return $ctx->responderr( $e );
168             }
169              
170 3         10 $ctx->respond( $response );
171             }
172              
173 3         7 sub handle_request_SUBSCRIBE ( $self, $token, $message )
  3         3  
174 3     3 0 6 {
  3         6  
  3         4  
175 3         16 my $ctx = Tangence::Server::Context->new( $self, $token );
176              
177 3         6 my $response;
178             try {
179             my $objid = $message->unpack_int();
180             my $event = $message->unpack_str();
181              
182             my $object = $self->get_by_id( $objid );
183              
184             weaken( my $weakself = $self );
185              
186             my $id = $object->subscribe_event( $event,
187             set_subname "__SUBSCRIBE($event)__" => sub {
188 2 50   2   6 $weakself or return;
189 2         4 my $object = shift;
190              
191 2         23 my $message = $object->generate_message_EVENT( $weakself, $event, @_ );
192             $weakself->request(
193             request => $message,
194 2         9 on_response => sub { "IGNORE" },
195 2         34 );
196             }
197             );
198              
199             push @{ $self->subscriptions }, [ $object, $event, $id ];
200              
201             $response = Tangence::Message->new( $self, MSG_SUBSCRIBED )
202             }
203 3         6 catch ( $e ) {
204             return $ctx->responderr( $e );
205             }
206              
207 2         10 $ctx->respond( $response );
208             }
209              
210 2         3 sub handle_request_UNSUBSCRIBE ( $self, $token, $message )
  2         4  
211 2     2 0 3 {
  2         14  
  2         3  
212 2         13 my $ctx = Tangence::Server::Context->new( $self, $token );
213              
214 2         9 my $response;
215             try {
216             my $objid = $message->unpack_int();
217             my $event = $message->unpack_str();
218              
219             my $object = $self->get_by_id( $objid );
220              
221             my $edef = $object->can_event( $event ) or
222             die "Object cannot respond to event $event\n";
223              
224             # Delete from subscriptions and obtain id
225             my $id;
226             @{ $self->subscriptions } = grep { $_->[0] == $object and $_->[1] eq $event and ( $id = $_->[2], 0 ) or 1 }
227             @{ $self->subscriptions };
228             defined $id or
229             die "Not subscribed to $event\n";
230              
231             $object->unsubscribe_event( $event, $id );
232              
233             $response = Tangence::Message->new( $self, MSG_OK )
234             }
235 2         6 catch ( $e ) {
236             return $ctx->responderr( $e );
237             }
238              
239 2         21 $ctx->respond( $response );
240             }
241              
242 5         11 sub handle_request_GETPROP ( $self, $token, $message )
  5         10  
243 5     5 0 11 {
  5         10  
  5         7  
244 5         32 my $ctx = Tangence::Server::Context->new( $self, $token );
245              
246 5         12 my $response;
247             try {
248             my $objid = $message->unpack_int();
249              
250             my $object = $self->get_by_id( $objid );
251              
252             $response = $object->handle_request_GETPROP( $ctx, $message )
253             }
254 5         15 catch ( $e ) {
255             return $ctx->responderr( $e );
256             }
257              
258 4         27 $ctx->respond( $response );
259             }
260              
261 4         6 sub handle_request_GETPROPELEM ( $self, $token, $message )
  4         6  
262 4     4 0 5 {
  4         6  
  4         5  
263 4         18 my $ctx = Tangence::Server::Context->new( $self, $token );
264              
265 4         8 my $response;
266             try {
267             my $objid = $message->unpack_int();
268              
269             my $object = $self->get_by_id( $objid );
270              
271             $response = $object->handle_request_GETPROPELEM( $ctx, $message )
272             }
273 4         9 catch ( $e ) {
274             return $ctx->responderr( $e );
275             }
276              
277 4         13 $ctx->respond( $response );
278             }
279              
280 9         13 sub handle_request_SETPROP ( $self, $token, $message )
  9         12  
281 9     9 0 14 {
  9         11  
  9         11  
282 9         36 my $ctx = Tangence::Server::Context->new( $self, $token );
283              
284 9         19 my $response;
285             try {
286             my $objid = $message->unpack_int();
287              
288             my $object = $self->get_by_id( $objid );
289              
290             $response = $object->handle_request_SETPROP( $ctx, $message )
291             }
292 9         20 catch ( $e ) {
293             return $ctx->responderr( $e );
294             }
295              
296 7         24 $ctx->respond( $response );
297             }
298              
299             *handle_request_WATCH = \&_handle_request_WATCHany;
300             *handle_request_WATCH_CUSR = \&_handle_request_WATCHany;
301 19         27 sub _handle_request_WATCHany ( $self, $token, $message )
  19         41  
302 19     19   43 {
  19         44  
  19         25  
303 19         123 my $ctx = Tangence::Server::Context->new( $self, $token );
304              
305 19         65 my ( $want_initial, $object, $prop );
306              
307 19         0 my $response;
308             try {
309             my $objid = $message->unpack_int();
310             $prop = $message->unpack_str();
311              
312             $object = $self->get_by_id( $objid );
313              
314             my $pdef = $object->can_property( $prop ) or
315             die "Object does not have property $prop\n";
316              
317             $self->_install_watch( $object, $prop );
318              
319             if( $message->code == MSG_WATCH ) {
320             $want_initial = $message->unpack_bool();
321              
322             $response = Tangence::Message->new( $self, MSG_WATCHING )
323             }
324             elsif( $message->code == MSG_WATCH_CUSR ) {
325             my $from = $message->unpack_int();
326              
327             my $m = "cursor_prop_$prop";
328             my $cursor = $object->$m( $from );
329             my $id = $self->message_state->{next_cursorid}++;
330              
331             $self->peer_hascursor->{$id} = CursorObject( $cursor, $object );
332             $response = Tangence::Message->new( $self, MSG_WATCHING_CUSR )
333             ->pack_int( $id )
334             ->pack_int( 0 ) # first index
335             ->pack_int( $#{ $object->${\"get_prop_$prop"} } ) # last index
336             }
337             }
338 19         53 catch ( $e ) {
339             return $ctx->responderr( $e );
340             }
341              
342 18         110 $ctx->respond( $response );
343              
344 18 100       98 $self->_send_initial( $object, $prop ) if $want_initial;
345             }
346              
347 8         16 sub _send_initial ( $self, $object, $prop )
  8         16  
348 8     8   24 {
  8         15  
  8         12  
349 8         25 my $m = "get_prop_$prop";
350 8 50       65 return unless( $object->can( $m ) );
351              
352             try {
353             my $value = $object->$m();
354             my $message = $object->generate_message_UPDATE( $self, $prop, CHANGE_SET, $value );
355             $self->request(
356             request => $message,
357 8     8   43 on_response => sub { "IGNORE" },
358             );
359             }
360 8         22 catch ( $e ) {
361             warn "$e during initial property fetch";
362             }
363             }
364              
365 4         7 sub handle_request_UNWATCH ( $self, $token, $message )
  4         5  
366 4     4 0 9 {
  4         6  
  4         7  
367 4         17 my $ctx = Tangence::Server::Context->new( $self, $token );
368              
369 4         24 my $response;
370             try {
371             my $objid = $message->unpack_int();
372             my $prop = $message->unpack_str();
373              
374             my $object = $self->get_by_id( $objid );
375              
376             my $pdef = $object->can_property( $prop ) or
377             die "Object does not have property $prop\n";
378              
379             # Delete from watches and obtain id
380             my $id;
381             @{ $self->watches } = grep { $_->[0] == $object and $_->[1] eq $prop and ( $id = $_->[2], 0 ) or 1 }
382             @{ $self->watches };
383             defined $id or
384             die "Not watching $prop\n";
385              
386             $object->unwatch_property( $prop, $id );
387              
388             $response = Tangence::Message->new( $self, MSG_OK );
389             }
390 4         13 catch ( $e ) {
391             return $ctx->responderr( $e );
392             }
393              
394 4         21 $ctx->respond( $response );
395             }
396              
397 12         18 sub handle_request_CUSR_NEXT ( $self, $token, $message )
  12         18  
398 12     12 0 27 {
  12         14  
  12         13  
399 12         24 my $cursor_id = $message->unpack_int();
400              
401 12         54 my $ctx = Tangence::Server::Context->new( $self, $token );
402              
403 12 50       43 my $cursorobj = $self->peer_hascursor->{$cursor_id} or
404             return $ctx->responderr( "No such cursor with id $cursor_id" );
405              
406 12         71 $cursorobj->cursor->handle_request_CUSR_NEXT( $ctx, $message );
407             }
408              
409 6         9 sub handle_request_CUSR_DESTROY ( $self, $token, $message )
  6         11  
410 6     6 0 8 {
  6         6  
  6         18  
411 6         17 my $cursor_id = $message->unpack_int();
412              
413 6         31 my $ctx = Tangence::Server::Context->new( $self, $token );
414              
415 6         21 my $cursorobj = delete $self->peer_hascursor->{$cursor_id};
416 6         33 $self->drop_cursorobj( $cursorobj );
417              
418 6         31 $ctx->respond( Tangence::Message->new( $self, MSG_OK ) );
419             }
420              
421 6         8 sub drop_cursorobj ( $self, $cursorobj )
422 6     6 0 9 {
  6         9  
  6         19  
423 6         34 my $m = "uncursor_prop_" . $cursorobj->cursor->prop->name;
424 6         22 $cursorobj->obj->$m( $cursorobj->cursor );
425             }
426              
427 9         27 sub handle_request_INIT ( $self, $token, $message )
  9         14  
428 9     9 0 16 {
  9         22  
  9         14  
429 9         45 my $major = $message->unpack_int();
430 9         35 my $minor_max = $message->unpack_int();
431 9         42 my $minor_min = $message->unpack_int();
432              
433 9         100 my $ctx = Tangence::Server::Context->new( $self, $token );
434              
435 9 50       37 if( $major != VERSION_MAJOR ) {
436 0         0 return $ctx->responderr( "Major version $major not available" );
437             }
438              
439             # Don't accept higher than the minor version we recognise
440 9 50       27 $minor_max = VERSION_MINOR if $minor_max > VERSION_MINOR;
441 9 50       27 $minor_min = VERSION_MINOR_MIN if $minor_min < VERSION_MINOR_MIN;
442              
443 9 50       31 if( $minor_max < $minor_min ) {
444 0         0 return $ctx->responderr( "No suitable minor version available" );
445             }
446              
447             # For unit tests or other synchronous cases, we need to set the version
448             # -before- we send the message. But we'd better construct the response
449             # message before setting the version, in case it makes a difference.
450 9         55 my $response = Tangence::Message->new( $self, MSG_INITED )
451             ->pack_int( $major )
452             ->pack_int( $minor_max );
453              
454 9         56 $self->minor_version( $minor_max );
455              
456 9         34 $ctx->respond( $response );
457             }
458              
459 9         17 sub handle_request_GETROOT ( $self, $token, $message )
  9         34  
460 9     9 0 18 {
  9         19  
  9         13  
461 9         42 my $identity = TYPE_ANY->unpack_value( $message );
462              
463 9         539 my $ctx = Tangence::Server::Context->new( $self, $token );
464              
465 9         66 $self->identity( $identity );
466              
467 9         49 my $root = $self->rootobj( $identity );
468              
469 9         66 my $response = Tangence::Message->new( $self, MSG_RESULT );
470 9         83 TYPE_OBJ->pack_value( $response, $root );
471              
472 9         85 $ctx->respond( $response );
473             }
474              
475 9         17 sub handle_request_GETREGISTRY ( $self, $token, $message )
  9         15  
476 9     9 0 19 {
  9         15  
  9         13  
477 9         49 my $ctx = Tangence::Server::Context->new( $self, $token );
478              
479 9 50       49 $self->permit_registry or
480             return $ctx->responderr( "This client is not permitted access to the registry" );
481              
482 9         51 my $response = Tangence::Message->new( $self, MSG_RESULT );
483 9         44 TYPE_OBJ->pack_value( $response, $self->registry );
484              
485 9         46 $ctx->respond( $response );
486             }
487              
488             my %change_values = (
489             on_set => CHANGE_SET,
490             on_add => CHANGE_ADD,
491             on_del => CHANGE_DEL,
492             on_push => CHANGE_PUSH,
493             on_shift => CHANGE_SHIFT,
494             on_splice => CHANGE_SPLICE,
495             on_move => CHANGE_MOVE,
496             );
497              
498 38         54 sub _install_watch ( $self, $object, $prop )
  38         53  
499 38     38   64 {
  38         62  
  38         72  
500 38         127 my $pdef = $object->can_property( $prop );
501 38         118 my $dim = $pdef->dimension;
502              
503 38         149 weaken( my $weakself = $self );
504              
505 38         65 my %callbacks;
506 38         55 foreach my $name ( @{ CHANGETYPES->{$dim} } ) {
  38         111  
507 106         217 my $how = $change_values{$name};
508             $callbacks{$name} = set_subname "__WATCH($prop:$name)__" => sub {
509 37 50   37   144 $weakself or return;
510 37         70 my $object = shift;
511              
512 37         205 my $message = $object->generate_message_UPDATE( $weakself, $prop, $how, @_ );
513             $weakself->request(
514             request => $message,
515 37         160 on_response => sub { "IGNORE" },
516 37         291 );
517 106         938 };
518             }
519              
520 38         237 my $id = $object->watch_property( $prop, %callbacks );
521              
522 38         67 push @{ $self->watches }, [ $object, $prop, $id ];
  38         154  
523             }
524              
525 2         2 sub object_destroyed ( $self, $obj, @rest )
  2         5  
526 2     2 0 7 {
  2         3  
  2         3  
527 2 50       8 if( my $subs = $self->subscriptions ) {
528 2         5 my $i = 0;
529 2         17 while( $i < @$subs ) {
530 2         8 my $s = $subs->[$i];
531              
532 2 50       7 $i++, next unless $s->[0] == $obj;
533              
534 2         6 my ( undef, $event, $id ) = @$s;
535 2         9 $obj->unsubscribe_event( $event, $id );
536              
537 2         9 splice @$subs, $i, 1;
538             # No $i++
539             }
540             }
541              
542 2 50       7 if( my $watches = $self->watches ) {
543 2         4 my $i = 0;
544 2         8 while( $i < @$watches ) {
545 8         11 my $w = $watches->[$i];
546              
547 8 50       16 $i++, next unless $w->[0] == $obj;
548              
549 8         15 my ( undef, $prop, $id ) = @$w;
550 8         21 $obj->unwatch_property( $prop, $id );
551              
552 8         52 splice @$watches, $i, 1;
553             # No $i++
554             }
555             }
556              
557 2         27 $self->SUPER::object_destroyed( $obj, @rest );
558             }
559              
560             =head1 OVERRIDEABLE METHODS
561              
562             The following methods are provided but intended to be overridden if the
563             implementing class wishes to provide different behaviour from the default.
564              
565             =cut
566              
567             =head2 rootobj
568              
569             $rootobj = $server->rootobj( $identity )
570              
571             Invoked when a C message is received from the client, this method
572             should return a L as root object for the connection.
573              
574             The default implementation will return the object with ID 1; i.e. the first
575             object created in the registry.
576              
577             =cut
578              
579             sub rootobj
580             {
581 9     9 1 16 my $self = shift;
582              
583 9         27 return $self->registry->get_by_id( 1 );
584             }
585              
586             =head2 permit_registry
587              
588             $allow = $server->permit_registry
589              
590             Invoked when a C message is received from the client, this method
591             should return a boolean to indicate whether the client is allowed to access
592             the object registry.
593              
594             The default implementation always permits this, but an overridden method may
595             decide to disallow it in some situations. When disabled, a client will not be
596             able to gain access to any serverside objects other than the root object, and
597             (recursively) any other objects returned by methods, events or properties on
598             objects already known. This can be used as a security mechanism.
599              
600             =cut
601              
602 9     9 1 28 sub permit_registry { 1; }
603              
604             =head1 AUTHOR
605              
606             Paul Evans
607              
608             =cut
609              
610             0x55AA;