Standalone "Log into remote Evergreen" perl module

Intended for use in implementing auth modules for outside projects

Signed-off-by: Thomas Berezansky <tsbere@mvlc.org>

diff --git a/Evergreen/Auth.pm b/Evergreen/Auth.pm
new file mode 100644 (file)
index 0000000..b32b374
--- /dev/null
+++ b/Evergreen/Auth.pm
@@ -0,0 +1,228 @@
+package Evergreen::Auth;
+
+use strict;
+use warnings;
+
+use JSON;
+use LWP::UserAgent;
+use Digest::MD5 qw(md5_hex);
+use XML::LibXML;
+
+my $ua = LWP::UserAgent->new(
+    ssl_opts => { SSL_verify_mode => 'SSL_VERIFY_NONE'} # TODO: REMOVE THIS FOR PRODUCTION MODE (my dev machine doesn't trust itself)
+);
+
+my %idl_fields;
+my %server_prefs;
+
+sub fieldmap {
+    my $server = shift;
+    my $object = shift;
+    return [ map { fieldmap($server, $_) } @$object ] if ref($object) eq 'ARRAY';
+    return $object if ref($object) ne 'HASH';
+    return $object unless defined $idl_fields{$server}{$object->{__c}};
+    my @idl = @{$idl_fields{$server}{$object->{__c}}};
+    my $newobject = {};
+    for (my $i=0; $i<=$#idl;$i++) {
+        $newobject->{$idl[$i]} = fieldmap($server, $object->{__p}->[$i]);
+    }
+    return $newobject;
+}
+
+sub fetch_idl {
+    my $server = shift;
+    my $req = HTTP::Request->new(GET => "https://$server/reports/fm_IDL.xml?class=aou&class=au&class=ausp&class=csp&class=pgt");
+    my $res = $ua->request($req);
+    if ($res->is_success) {
+        # IDL fetch has content. But is it XML?
+        my $parser = XML::LibXML->new(recover => 2);
+        my $xmldoc = $parser->parse_string($res->content);
+        return 0 unless $xmldoc and $xmldoc->documentElement->nodeName eq 'IDL';
+        my $rootnode = $xmldoc->documentElement;
+        my @classnodes = $rootnode->findnodes('idl:class');
+        foreach my $classnode (@classnodes) {
+            my $classname = $classnode->getAttribute('id');
+            my @fields = $classnode->findnodes('idl:fields/idl:field');
+            $idl_fields{$server}{$classname} = [ map { $_->getAttribute('name') } @fields ];
+        }
+        return 1;
+    }
+    return 0;
+}
+
+sub build_osrf_class {
+    my $class = shift;
+    my $payload = shift;
+    my $hash = {
+        __c => $class,
+        __p => $payload
+    };
+}
+
+sub build_osrf_message {
+    my $method = shift;
+    my $message = build_osrf_class('osrfMessage', {
+        threadTrace => 0,
+        type => 'REQUEST',
+        locale => 'en-US',
+        payload => build_osrf_class('osrfMethod', {
+            method => $method,
+            params => shift
+        })
+    });
+}
+
+sub build_request {
+    my $server = shift;
+    my $service = shift;
+    my $message = encode_json(shift);
+    return HTTP::Request->new(
+        'POST',
+        "https://$server/osrf-http-translator",
+        [
+            'content-type' => 'application/x-www-form-urlencoded',
+            'X-OpenSRF-service' => $service
+        ],
+        "osrf-msg=[$message]"
+    );
+}
+
+sub get_result {
+    my $content = shift;
+    my $returnerrors = shift;
+    my $osrfres = eval { decode_json($content) };
+    return undef unless $osrfres and ref($osrfres) eq 'ARRAY' and ref($osrfres->[0]) eq 'HASH';
+    my $message = $osrfres->[0];
+    return undef unless $message->{__c} eq 'osrfMessage';
+    my $result = $message->{__p}->{payload};
+    return undef unless $result->{__c} eq 'osrfResult';
+    return undef unless $result->{__p}->{statusCode} == 200;
+    my $resultc = $result->{__p}->{content};
+    if (ref($resultc) eq 'HASH') {
+        return undef if ($resultc->{ilsevent} and not $returnerrors);
+        return $resultc if ($resultc->{ilsevent});
+        $resultc = $resultc->{payload} if (defined($resultc->{ilsevent}) and defined($resultc->{payload}));
+    }
+    return $resultc;
+}
+
+sub fetch_prefs {
+    my $server = shift;
+    my $org_unit = shift || 1;
+    $server_prefs{$server}{$org_unit}{fetched} = 0;
+
+    # First Up, Auth Proxy Usage
+    # This is allowed to fail silently!
+    my $proxymessage = build_osrf_message('open-ils.auth_proxy.enabled',[]);
+    my $req = build_request($server, 'open-ils.auth_proxy', $proxymessage);
+    my $res = $ua->request($req);
+    # Assume we don't first
+    $server_prefs{$server}{proxy} = 0;
+    if ($res->is_success) {
+        my $result = get_result($res->content);
+        if (defined $result) {
+            $server_prefs{$server}{proxy} = int($result);
+        }
+    }
+
+    # Next Up, Barcode Regex
+    # If this fails outright we have an issue
+    my $barcodemessage = build_osrf_message('open-ils.actor.ou_setting.ancestor_default',[$org_unit, 'opac.barcode_regex']);
+    $req = build_request($server, 'open-ils.actor', $barcodemessage);
+    $res = $ua->request($req);
+    # Assume starts with digits
+    $server_prefs{$server}{$org_unit}{barcode_regex} = '^\d';
+    if ($res->is_success) {
+        my $result = get_result($res->content);
+        if (defined $result) {
+            $server_prefs{$server}{$org_unit}{barcode_regex} = $result;
+        }
+    } else {
+        return 0;
+    }
+
+    $server_prefs{$server}{$org_unit}{fetched} = 1;
+    return 1;
+}
+
+sub do_login {
+    my $server = shift;
+    my $username = shift;
+    my $password = shift;
+    my $org_unit = shift || 1;
+    my $workstation = shift;
+
+    fetch_prefs($server, $org_unit) unless $server_prefs{$server}{$org_unit}{fetched};
+
+    my $params = {
+        type => 'opac',
+        org => 1,
+        agent => 'remotelogin',
+    };
+    if ($username =~ $server_prefs{$server}{$org_unit}{barcode_regex}) {
+        $params->{barcode} = $username;
+    } else {
+        $params->{username} = $username;
+    }
+
+    if ($server_prefs{$server}{proxy}) {
+        $params->{password} = $password;
+        my $proxylogin = build_osrf_message('open-ils.auth_proxy.login', [$params]);
+        my $req = build_request($server, 'open-ils.auth_proxy', $proxylogin);
+        my $res = $ua->request($req);
+        if ($res->is_success) {
+            return get_result($res->content, 1);
+        }
+    } else {
+        my $authinit = build_osrf_message('open-ils.auth.authenticate.init', [$username]);
+        my $req = build_request($server, 'open-ils.auth', $authinit);
+        my $res = $ua->request($req);
+        if ($res->is_success) {
+            my $seed = get_result($res->content);
+            $params->{password} = md5_hex($seed . md5_hex($password));
+            my $authcomplete = build_osrf_message('open-ils.auth.authenticate.complete', [$params]);
+            $req = build_request($server, 'open-ils.auth', $authcomplete);
+            $res = $ua->request($req);
+            if ($res->is_success) {
+                return get_result($res->content, 1);
+            }
+        }
+    }
+}
+
+sub fetch_user {
+    my $server = shift;
+    my $authinfo = shift;
+    my $advanced = shift;
+
+    # Base info, session retrieval
+    my $sessionr = build_osrf_message('open-ils.auth.session.retrieve', [$authinfo->{authtoken}]);
+    my $req = build_request($server, 'open-ils.auth', $sessionr);
+    my $res = $ua->request($req);
+    if ($res->is_success) {
+        my $user = fieldmap($server, get_result($res->content));
+        if ($advanced) {
+            my $fleshuser = build_osrf_message('open-ils.actor.user.fleshed.retrieve', [$authinfo->{authtoken}, $user->{id}, ['profile','home_ou','standing_penalties']]);
+            $req = build_request($server, 'open-ils.actor', $fleshuser);
+            $res = $ua->request($req);
+            if ($res->is_success) {
+                $user = fieldmap($server, get_result($res->content));
+            }
+        }
+        return $user;
+    }
+    return undef;
+}
+
+sub fetch_group_tree {
+    my $server = shift;
+    my $msg = build_osrf_message('open-ils.actor.groups.tree.retrieve', []);
+    my $req = build_request($server, 'open-ils.actor', $msg);
+    my $res = $ua->request($req);
+    if ($res->is_success) {
+        return fieldmap($server, get_result($res->content));
+    }
+    return undef;
+}
+
+1;

diff --git a/test.pl b/test.pl
new file mode 100755 (executable)
index 0000000..aec9730
--- /dev/null
+++ b/test.pl
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+use Data::Dumper;
+use Evergreen::Auth;
+
+my $server = 'localhost';
+
+Evergreen::Auth::fetch_idl($server);
+my $authinfo = Evergreen::Auth::do_login($server,"admin","evergreen");
+if ($authinfo->{ilsevent}) {
+    die "AUTH FAILED!\n";
+}
+print Dumper(Evergreen::Auth::fetch_user($server,$authinfo,1));
+print Dumper(Evergreen::Auth::fetch_group_tree($server));