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