1package Ace::SocketServer;
2
3require 5.004;
4use strict;
5use Carp 'croak','cluck';
6use Ace qw(rearrange STATUS_WAITING STATUS_PENDING STATUS_ERROR);
7use IO::Socket;
8use Digest::MD5 'md5_hex';
9
10use vars '$VERSION';
11$VERSION = '1.01';
12
13use constant DEFAULT_USER    => 'anonymous';  # anonymous user
14use constant DEFAULT_PASS    => 'guest';      # anonymous password
15use constant DEFAULT_TIMEOUT => 120;          # two minute timeout on queries
16
17# header information
18use constant HEADER => 'L5a30';
19use constant HEADER_LEN => 5*4+30;
20use constant ACESERV_MSGREQ   => "ACESERV_MSGREQ";
21use constant ACESERV_MSGDATA  => "ACESERV_MSGDATA";
22use constant WORDORDER_MAGIC => 0x12345678;
23
24# Server only, it may just be sending or a reply or it may be sending an
25# instruction, such as "operation refused".
26use constant ACESERV_MSGOK     => "ACESERV_MSGOK";
27use constant ACESERV_MSGENCORE => "ACESERV_MSGENCORE";
28use constant ACESERV_MSGFAIL   => "ACESERV_MSGFAIL";
29use constant ACESERV_MSGKILL   => "ACESERV_MSGKILL";
30
31use constant ACESERV_CLIENT_HELLO => "bonjour";
32use constant ACESERV_SERVER_HELLO => "et bonjour a vous";
33
34sub connect {
35  my $class = shift;
36  my ($host,$port,$timeout,$user,$pass) = rearrange(['HOST','PORT','TIMEOUT','USER','PASS'],@_);
37  $user    ||= DEFAULT_USER;
38  $pass    ||= DEFAULT_PASS;
39  $timeout ||= DEFAULT_TIMEOUT;
40  my $s = IO::Socket::INET->new("$host:$port") ||
41    return _error("Couldn't establish connection");
42  my $self = bless { socket    => $s,
43		     client_id => 0,  # client ID provided by server
44		     timeout   => $timeout,
45		   },$class;
46  return unless $self->_handshake($user,$pass);
47  $self->{status} = STATUS_WAITING;
48  $self->{encoring} = 0;
49  return $self;
50}
51
52sub DESTROY {
53  my $self = shift;
54  return if $self->{last_msg} eq ACESERV_MSGKILL;
55  $self->_send_msg('quit');
56# Is _recv_msg() bringing things down in flames?  Maybe!
57  my ($msg,$body) = $self->_recv_msg('strip');
58  warn "Did not get expected ACESERV_MSGKILL message, got $msg instead"
59    if defined($msg) and $msg ne ACESERV_MSGKILL;
60}
61
62sub encore { return shift->{encoring} }
63
64sub status { shift->{status} }
65
66sub error { $Ace::Error; }
67
68sub query {
69  my $self = shift;
70  my ($request,$parse) = @_;
71  warn "query($request)" if Ace->debug;
72  unless ($self->_send_msg($request,$parse)) {
73    $self->{status} = STATUS_ERROR;
74    return _error("Write to socket server failed: $!");
75  }
76  $self->{status} = STATUS_PENDING;
77  $self->{encoring} = 0;
78  return 1;
79}
80
81sub read {
82  my $self = shift;
83  return _error("No pending query") unless $self->status == STATUS_PENDING;
84  $self->_do_encore || return if $self->encore;
85  # call select() here to time out
86
87  if ($self->{timeout}) {
88      my $rdr = '';
89      vec($rdr,fileno($self->{socket}),1) = 1;
90      my $result = select($rdr,undef,undef,$self->{timeout});
91      return _error("Query timed out") unless $result;
92  }
93
94  my ($msg,$body) = $self->_recv_msg;
95  return unless defined $msg;
96  $msg =~ s/\0.+$//;  # socketserver bug workaround: get rid of junk in message
97  if ($msg eq ACESERV_MSGOK or $msg eq ACESERV_MSGFAIL) {
98    $self->{status}   = STATUS_WAITING;
99    $self->{encoring} = 0;
100  } elsif ($msg eq ACESERV_MSGENCORE) {
101    $self->{status}   = STATUS_PENDING;  # not strictly necessary, but helpful to document
102    $self->{encoring} = 1;
103  } else {
104    $self->{status}   = STATUS_ERROR;
105    return _error($body);
106  }
107  return $body;
108}
109
110sub write {
111  my $self = shift;
112  my $data = shift;
113  unless ($self->_send_msg($data,1)) {
114    $self->{status} = STATUS_ERROR;
115    return _error("Write to socket server failed: $!");
116  }
117  $self->{status} = STATUS_PENDING;
118  $self->{encoring} = 0;
119  return 1;
120}
121
122sub _error {
123  $Ace::Error = shift;
124  return;
125}
126
127# return socket (read only)
128sub socket { $_[0]->{socket} }
129
130# ----------------------------- low level -------------------------------
131sub _do_encore {
132  my $self = shift;
133  unless ($self->_send_msg('encore')) {
134    $self->{status} = STATUS_ERROR;
135    return _error("Write to socket server failed: $!");
136  }
137  $self->{status} = STATUS_PENDING;
138  return 1;
139}
140sub _handshake {
141  my $self = shift;
142  my ($user,$pass) = @_;
143  $self->_send_msg(ACESERV_CLIENT_HELLO);
144  my ($msg,$nonce) = $self->_recv_msg('strip');
145  return unless $msg eq ACESERV_MSGOK;
146  # hash username and password
147  my $authdigest = md5_hex(md5_hex($user . $pass).$nonce);
148  $self->_send_msg("$user $authdigest");
149  my $body;
150  ($msg,$body) = $self->_recv_msg('strip');
151  return _error("server: $body") unless $body eq ACESERV_SERVER_HELLO;
152  return 1;
153}
154
155sub _send_msg {
156  my ($self,$msg,$parse) = @_;
157  return unless my $sock = $self->{socket};
158  local $SIG{'PIPE'} = 'IGNORE';
159  $msg .= "\0";  # add terminating null
160  my $request;
161  if ($parse) {
162    $request = ACESERV_MSGDATA;
163  } else {
164    $request = $msg eq "encore\0" ? ACESERV_MSGENCORE : ACESERV_MSGREQ;
165  }
166  my $header  = pack HEADER,WORDORDER_MAGIC,length($msg),0,$self->{client_id},0,$request;
167  print $sock $header,$msg;
168}
169
170sub _recv_msg {
171  my $self = shift;
172  my $strip_null = shift;
173  return unless my $sock = $self->{socket};
174  my ($header,$body);
175  my $bytes = CORE::read($sock,$header,HEADER_LEN);
176  unless ($bytes > 0) {
177    $self->{status} = STATUS_ERROR;
178    return _error("Connection closed by remote server: $!");
179  }
180  my ($magic,$length,$junk1,$clientID,$junk2,$msg) = unpack HEADER,$header;
181  $self->{client_id} ||= $clientID;
182  $msg =~ s/\0*$//;
183  $self->{last_msg} = $msg;
184  if ($length > 0) {
185    return _error("read of body failed: $!" )
186      unless CORE::read($sock,$body,$length);
187    $body =~ s/\0*$// if defined($strip_null) && $strip_null;
188    return ($msg,$body);
189  } else {
190    return $msg;
191  }
192}
193
1941;
195
196__END__
197