1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
# You may distribute under the terms of either the GNU General Public License
# or the Artistic License (the same terms as Perl itself)
#
# (C) Paul Evans, 2010-2020 -- leonerd@leonerd.org.uk
package Net::Async::Tangence::Server 0.16;
use v5.14;
use warnings;
use IO::Async::Listener '0.36';
use base qw( IO::Async::Listener );
use Carp;
use Net::Async::Tangence::ServerProtocol;
=head1 NAME
C<Net::Async::Tangence::Server> - serve C<Tangence> clients using C<IO::Async>
=head1 DESCRIPTION
This subclass of L<IO::Async::Listener> accepts L<Tangence> client
connections.
=cut
=head1 PARAMETERS
The following named parameters may be passed to C<new> or C<configure>:
=over 8
=item registry => Tangence::Registry
The L<Tangence::Registry> for the server's objects.
=back
=cut
sub _init
{
my $self = shift;
my ( $params ) = @_;
$params->{handle_constructor} = sub {
my $self = shift;
return Net::Async::Tangence::ServerProtocol->new(
registry => $self->{registry},
on_closed => $self->_capture_weakself( sub {
my $self = shift;
$self->remove_child( $_[0] );
} ),
);
};
$self->SUPER::_init( $params );
$self->{registry} = delete $params->{registry} if exists $params->{registry};
}
sub on_accept
{
my $self = shift;
my ( $conn ) = @_;
$self->add_child( $conn );
}
# Useful for testing
sub make_new_connection
{
my $self = shift;
my ( $sock ) = @_;
# Mass cheating
my $conn = $self->{handle_constructor}->( $self );
$conn->configure( handle => $sock );
$self->on_accept( $conn );
return $conn;
}
# More testing utilities
sub accept_stdio
{
my $self = shift;
my $conn = $self->{handle_constructor}->( $self );
$conn->configure(
read_handle => \*STDIN,
write_handle => \*STDOUT,
);
$self->on_accept( $conn );
return $conn;
}
=head1 OVERRIDEABLE METHODS
The following methods are provided but intended to be overridden if the
implementing class wishes to provide different behaviour from the default.
=cut
=head2 conn_rootobj
$rootobj = $server->conn_rootobj( $conn, $identity )
Invoked when a C<GETROOT> message is received from the client, this method
should return a L<Tangence::Object> as root object for the connection.
The default implementation will return the object with ID 1; i.e. the first
object created in the registry.
=cut
sub conn_rootobj
{
my $self = shift;
return $self->{registry}->get_by_id( 1 );
}
=head2 conn_permits_registry
$allow = $server->conn_permits_registry( $conn )
Invoked when a C<GETREGISTRY> message is received from the client on the given
connection object. This method should return a boolean to indicate whether the
client is allowed to access the object registry.
The default implementation always permits this, but an overridden method may
decide to disallow it in some situations. When disabled, a client will not be
able to gain access to any serverside objects other than the root object, and
(recursively) any other objects returned by methods, events or properties on
objects already known. This can be used as a security mechanism.
=cut
sub conn_permits_registry
{
return 1;
}
=head1 AUTHOR
Paul Evans <leonerd@leonerd.org.uk>
=cut
0x55AA;
|
