perl websocket client PoC

Signed-off-by: Bill Erickson <berickxx@gmail.com>

diff --git a/src/extras/perl-websocket-client.pl b/src/extras/perl-websocket-client.pl
new file mode 100755 (executable)
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 (file)
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 <berickxx@gmail.com>
+#
+# 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;
+