From 398d5470f8a1153b5b611ec3a1cee2798cb67c1d Mon Sep 17 00:00:00 2001 From: Bill Erickson Date: Sat, 5 Mar 2016 15:02:44 -0500 Subject: [PATCH] perl websocket client PoC Signed-off-by: Bill Erickson --- src/extras/perl-websocket-client.pl | 45 ++++++ src/perl/lib/OpenSRF/Utils/WebSocketsClient.pm | 193 +++++++++++++++++++++++++ 2 files changed, 238 insertions(+) create mode 100755 src/extras/perl-websocket-client.pl create mode 100644 src/perl/lib/OpenSRF/Utils/WebSocketsClient.pm diff --git a/src/extras/perl-websocket-client.pl b/src/extras/perl-websocket-client.pl new file mode 100755 index 0000000..be06d88 --- /dev/null +++ b/src/extras/perl-websocket-client.pl @@ -0,0 +1,45 @@ +#!/usr/bin/perl +use strict; +use warnings; +use IO::Socket::SSL; # for params +use OpenSRF::Utils::WebSocketsClient; +use OpenSRF::DomainObject::oilsMethod; +use OpenSRF::DomainObject::oilsMessage; + +my $method = OpenSRF::DomainObject::oilsMethod->new( + method => 'opensrf.system.echo', + params => ['hello, world'] +); +my $msg = OpenSRF::DomainObject::oilsMessage->new( + type => 'REQUEST', + api_level => 1, + locale => 'en-US', + threadTrace => 0, + payload => $method +); + +# connects to localhost by default +my $client = OpenSRF::Utils::WebSocketsClient->new( + ssl_params => { # testing only + SSL_verify_mode => SSL_VERIFY_NONE + } +); + +die "cound not connect\n" unless $client->connect; + +$client->send({ + service => 'open-ils.auth', + thread => rand(), + osrf_msg => [$msg] +}); + +my $response = $client->recv(-1); +my $messages = $response->{osrf_msg}; + +for my $msg (@$messages) { + print "received: " . + OpenSRF::Utils::JSON->perl2JSON($msg) . "\n\n"; +} + + + diff --git a/src/perl/lib/OpenSRF/Utils/WebSocketsClient.pm b/src/perl/lib/OpenSRF/Utils/WebSocketsClient.pm new file mode 100644 index 0000000..da4be56 --- /dev/null +++ b/src/perl/lib/OpenSRF/Utils/WebSocketsClient.pm @@ -0,0 +1,193 @@ +package OpenSRF::Utils::WebSocketsClient; +# ------------------------------------------------------------- +# Copyright (C) 2016, King County Library System +# Bill Erickson +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# ------------------------------------------------------------- +# +# WebSocketsClient library. +# +# SSL only for now. +# +# ------------------------------------------------------------- +use strict; +use warnings; +use IO::Socket::SSL; +use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); +use Protocol::WebSocket::Client; +use OpenSRF::Utils::JSON; + +sub new { + my ($class, %args) = @_; + + my $self = { + host => $args{host} || 'localhost', + port => $args{port} || 7682, + path => $args{path} || '/osrf-websocket-translator', + ssl_params => $args{ssl_params} || {}, + connected => 0, + responses => [] + }; + + return bless($self, $class); +} + +sub connect { + my $self = shift; + + $self->connect_socket or return undef; + + my $url = sprintf("wss://%s:%d", $self->{host}, $self->{port}); + $url .= '/' . $self->{path} if $self->{path}; + + my $client = Protocol::WebSocket::Client->new( + url => $url, + on_write => sub { + my ($client, $data) = @_; + $self->{socket}->print($data); + }, + on_connect => sub { + my $client = shift; + $self->{connected} = 1; + }, + on_error => sub { + my ($client, $error) = @_; + warn "ERROR: $error\n"; + $self->disconnect; + } + ); + + $client->on( + # add resposnes to the response queue + read => sub { + my ($client, $data) = @_; + push(@{$self->{responses}}, + OpenSRF::Utils::JSON->JSON2perl($data)); + } + ); + + $self->{client} = $client; # needed in connect/recv callback + + $client->connect; + + while (!$self->{connected}) { $self->recv(-1) } + + return 1; +} + +sub connect_socket { + my $self = shift; + + my $sock = IO::Socket::SSL->new( + PeerHost => $self->{host}, + PeerPort => int($self->{port}), + Proto => 'tcp', + %{$self->{ssl_params}} + ); + + return $self->{socket} = $sock if $sock && $sock->connected; + + warn "SSL socket connection failed to ". + $self->{host}.":".$self->{port}." => $!\n"; + + return undef; +} + +sub send { + my ($self, $msg) = @_; + my $json = OpenSRF::Utils::JSON->perl2JSON($msg); + $self->{client}->write($json); +} + +sub next_msg { + my $self = shift; + return shift @{$self->{responses}}; +} + +sub peek_msg { + my $self = shift; + return (@{$self->{responses}} > 0); +} + +sub recv { + my ($self, $timeout) = @_; + return $self->next_msg if $self->peek_msg; + + $timeout ||= 0; + $timeout = undef if $timeout < 0; + my $socket = $self->{socket}; + + set_block($socket); + + # build the select readset + my $infile = ''; + vec($infile, $socket->fileno, 1) = 1; + + my $nfound = select($infile, undef, undef, $timeout); + return undef if !$nfound or $nfound == -1; + + # now slurp the data off the socket + my $buf; + my $read_size = 1024; + my $nonblock = 0; + my $nbytes; + my $first_read = 1; + + while($nbytes = sysread($socket, $buf, $read_size)) { + $self->{client}->read($buf); + if($nbytes < $read_size or $self->peek_msg) { + set_block($socket) if $nonblock; + last; + } + set_nonblock($socket) unless $nonblock; + $nonblock = 1; + $first_read = 0; + } + + if ($first_read and defined $nbytes and $nbytes == 0) { + # if the first read on an active socket is 0 bytes, + # the socket has been disconnected from the remote end. + die "Disconnected from Jabber server\n"; + } + + return $self->next_msg; +} + +sub disconnect { + my $self = shift; + $self->{connected} = 0; + return unless $self->{client}; + $self->{client}->disconnect; + delete $self->{client}; +} + +# ----------------------------------------------------------- +# Puts a file handle into blocking mode +# ----------------------------------------------------------- +sub set_block { + my $fh = shift; + my $flags = fcntl($fh, F_GETFL, 0); + $flags &= ~O_NONBLOCK; + fcntl($fh, F_SETFL, $flags); +} + +# ----------------------------------------------------------- +# Puts a file handle into non-blocking mode +# ----------------------------------------------------------- +sub set_nonblock { + my $fh = shift; + my $flags = fcntl($fh, F_GETFL, 0); + fcntl($fh, F_SETFL, $flags | O_NONBLOCK); +} + +1; + -- 2.11.0