|
|
@@ -0,0 +1,506 @@
|
|
|
+--- /dev/null 2005-11-27 00:46:14 +0100
|
|
|
++++ ase.pm 2005-11-27 00:47:12 +0100
|
|
|
+@@ -0,0 +1,503 @@
|
|
|
++##
|
|
|
++## OSSP ase -- Affiliation Service Environment
|
|
|
++## Copyright (c) 2005 Ralf S. Engelschall <rse@engelschall.com>
|
|
|
++## Copyright (c) 2005 The OSSP Project <http://www.ossp.org/>
|
|
|
++##
|
|
|
++## This file is part of OSSP ase, a service environment for managing
|
|
|
++## affiliations which can be found at http://www.ossp.org/pkg/tool/ase/.
|
|
|
++##
|
|
|
++## 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.
|
|
|
++##
|
|
|
++## You should have received a copy of the GNU General Public License
|
|
|
++## along with this program; if not, write to the Free Software
|
|
|
++## Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
|
|
|
++## USA, or contact Ralf S. Engelschall <rse@engelschall.com>.
|
|
|
++##
|
|
|
++## ase.pm: client API
|
|
|
++##
|
|
|
++
|
|
|
++package OSSP::ase::client;
|
|
|
++
|
|
|
++use 5.008;
|
|
|
++use strict;
|
|
|
++use warnings;
|
|
|
++use base 'Exporter';
|
|
|
++
|
|
|
++our $VERSION = do { my @v = ('0.0.1' =~ m/\d+/g); sprintf("%d.".("%02d"x$#v), @v); };
|
|
|
++
|
|
|
++our @EXPORT_OK = ();
|
|
|
++our @EXPORT = ();
|
|
|
++
|
|
|
++# names of valid ASE session attributes
|
|
|
++my @valid_attributes = qw(
|
|
|
++ session-id
|
|
|
++ session-valid
|
|
|
++ session-created
|
|
|
++ session-expires
|
|
|
++ canvas-url
|
|
|
++ canvas-mark-head
|
|
|
++ canvas-mark-body
|
|
|
++ client-address
|
|
|
++ client-login-uuid
|
|
|
++ client-login-name
|
|
|
++);
|
|
|
++
|
|
|
++# textual markers for canvas
|
|
|
++my $canvas_mark = {
|
|
|
++ head => "<!-- ASE: HEAD -->",
|
|
|
++ body => "<!-- ASE: BODY -->"
|
|
|
++};
|
|
|
++
|
|
|
++# lazy loading of modules
|
|
|
++sub _use ($$) {
|
|
|
++ my ($self, $name) = @_;
|
|
|
++ if (not defined($self->{-use}->{$name})) {
|
|
|
++ eval "require $name; import $name;";
|
|
|
++ $self->{-use}->{$name} = 1;
|
|
|
++ }
|
|
|
++ return;
|
|
|
++}
|
|
|
++
|
|
|
++# debugging: time identification
|
|
|
++sub _time () {
|
|
|
++ my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time());
|
|
|
++ return sprintf("%04d-%02d-%02d %02d:%02d:%02d", $year, $mon+1, $mday, $hour, $min, $sec);
|
|
|
++}
|
|
|
++
|
|
|
++# debugging: message formatting
|
|
|
++sub _debug ($$;@) {
|
|
|
++ my ($self, $fmt, @args) = @_;
|
|
|
++
|
|
|
++ return if (not defined($self->{-debug}));
|
|
|
++ if (defined($args[0])) {
|
|
|
++ $self->{-debug}->printf("%s $fmt\n", $self->_time(), @args);
|
|
|
++ }
|
|
|
++ else {
|
|
|
++ $self->{-debug}->printf("%s %s\n", $self->_time(), $fmt);
|
|
|
++ }
|
|
|
++ return;
|
|
|
++}
|
|
|
++
|
|
|
++# debugging: structure dumping
|
|
|
++sub _dump ($;@) {
|
|
|
++ my ($self, $prefix, @args) = @_;
|
|
|
++
|
|
|
++ return if (not defined($self->{-debug}));
|
|
|
++ $self->_use("Data::Dumper");
|
|
|
++ my $d = Data::Dumper->new([@args]);
|
|
|
++ $d->Purity(0);
|
|
|
++ $d->Indent(1);
|
|
|
++ $d->Terse(1);
|
|
|
++ $d->Pad(sprintf("%s %s| ", $self->_time()), $prefix);
|
|
|
++ $self->{-debug}->print($d->Dump());
|
|
|
++ return;
|
|
|
++}
|
|
|
++
|
|
|
++# object constructor
|
|
|
++sub new {
|
|
|
++ my $proto = shift;
|
|
|
++ my %args = @_;
|
|
|
++
|
|
|
++ # create new object
|
|
|
++ my $class = ref($proto) || $proto;
|
|
|
++ my $self = {};
|
|
|
++ bless ($self, $class);
|
|
|
++
|
|
|
++ # fill object with attributes
|
|
|
++ $self->{-server} = ($args{-server} || die "no OSSP ase server URL specified with \"-server\"");
|
|
|
++ $self->{-cgi} = ($args{-cgi} || new CGI);
|
|
|
++ $self->{-session} = ($args{-session} || new CGI::Session);
|
|
|
++ $self->{-mode} = ($args{-mode} || "mode");
|
|
|
++ $self->{-valid} = ($args{-valid} || 0);
|
|
|
++ $self->{-debug} = ($args{-debug} || undef);
|
|
|
++ $self->{-response} = "";
|
|
|
++ $self->{-error} = "";
|
|
|
++ $self->{-use} = {};
|
|
|
++
|
|
|
++ # optionally open debug logfile
|
|
|
++ if (defined($self->{-debug})) {
|
|
|
++ $self->_use("IO::File");
|
|
|
++ $self->{-debug} = IO::File->new(">>" . $self->{-debug})
|
|
|
++ or die "failed to open debug logfile: $!";
|
|
|
++ }
|
|
|
++
|
|
|
++ # return object
|
|
|
++ return $self;
|
|
|
++}
|
|
|
++
|
|
|
++# object destructor (explicit)
|
|
|
++sub destroy ($) {
|
|
|
++ my ($self) = @_;
|
|
|
++
|
|
|
++ # shutdown sub-objects
|
|
|
++ $self->{-session}->flush() if (defined($self->{-session}));
|
|
|
++ $self->{-debug}->close() if (defined($self->{-debug}));
|
|
|
++
|
|
|
++ # destroy sub-objects
|
|
|
++ delete $self->{-cgi};
|
|
|
++ delete $self->{-session};
|
|
|
++ delete $self->{-debug};
|
|
|
++
|
|
|
++ return;
|
|
|
++}
|
|
|
++
|
|
|
++# object destructor (implicit)
|
|
|
++sub DESTROY ($) {
|
|
|
++ my ($self) = @_;
|
|
|
++ $self->destroy();
|
|
|
++ return;
|
|
|
++}
|
|
|
++
|
|
|
++# run-time responsibility check
|
|
|
++sub responsible ($) {
|
|
|
++ my ($self) = @_;
|
|
|
++
|
|
|
++ my $action = $self->{-cgi}->url_param("ase-action") || "";
|
|
|
++ return $action =~ m/^(login|logout|info|comeback)$/;
|
|
|
++}
|
|
|
++
|
|
|
++# run-time action handler
|
|
|
++sub action ($;%) {
|
|
|
++ my ($self, %args) = @_;
|
|
|
++
|
|
|
++ # debugging
|
|
|
++ $self->_debug("action: client-sid=%s server-sid=%s",
|
|
|
++ $self->{-session}->id(), $self->attr("session-id") || "none");
|
|
|
++
|
|
|
++ my $action = $self->{-cgi}->url_param("ase-action") || "";
|
|
|
++ if ($action =~ m/^(login|logout|info)$/) {
|
|
|
++ #
|
|
|
++ # request ASE actions
|
|
|
++ #
|
|
|
++ my $mode_during = $self->{-cgi}->url_param("ase-mode-during")
|
|
|
++ or { $self->error("CGI parameter \"ase-mode-during\" missing or empty"), return 0 };
|
|
|
++ my $mode_after = $self->{-cgi}->url_param("ase-mode-after")
|
|
|
++ or { $self->error("CGI parameter \"ase-mode-after\" missing or empty"), return 0 };
|
|
|
++
|
|
|
++ # debugging
|
|
|
++ $self->_debug("action: action=%s mode-during=%s mode-after=%s", $action, $mode_during, $mode_after);
|
|
|
++
|
|
|
++ # remember mode after action
|
|
|
++ $self->attr("mode-after", $mode_after);
|
|
|
++
|
|
|
++ # determine URLs for canvas and return
|
|
|
++ my $canvas = sprintf("%s?%s=%s",
|
|
|
++ $self->{-cgi}->url(-full => 1), $self->{-mode}, $mode_during);
|
|
|
++ my $return = sprintf("%s?ase-action=comeback;ase-action-old=%s;ase-sid=%%s",
|
|
|
++ $self->{-cgi}->url(-full => 1), $action);
|
|
|
++
|
|
|
++ # determine URL for server request
|
|
|
++ $self->_use("URI::Escape");
|
|
|
++ my $url = sprintf(
|
|
|
++ "%s?mode=rpc;method=%s;" .
|
|
|
++ "return=%s;canvas=%s;canvas_mark_head=%s;canvas_mark_body=%s",
|
|
|
++ $self->{-server}, $action,
|
|
|
++ URI::Escape::uri_escape($return),
|
|
|
++ URI::Escape::uri_escape($canvas),
|
|
|
++ URI::Escape::uri_escape($canvas_mark->{"head"}),
|
|
|
++ URI::Escape::uri_escape($canvas_mark->{"body"}));
|
|
|
++
|
|
|
++ # redirect to server request URL
|
|
|
++ $self->response($self->{-cgi}->redirect(-url => $url, -status => 302));
|
|
|
++ return 1;
|
|
|
++ }
|
|
|
++ elsif ($action eq 'comeback') {
|
|
|
++ #
|
|
|
++ # respond to ASE actions
|
|
|
++ #
|
|
|
++ my $action_old = $self->{-cgi}->url_param("ase-action-old")
|
|
|
++ or { $self->error("CGI parameter \"ase-action-old\" missing or empty"), return 0 };
|
|
|
++ my $sid = $self->{-cgi}->url_param("ase-sid")
|
|
|
++ or { $self->error("CGI parameter \"ase-sid\" missing or empty"), return 0 };
|
|
|
++
|
|
|
++ $self->_debug("action: action=%s action-old=%s sid=%s", $action, $action_old, $sid);
|
|
|
++
|
|
|
++ # sanity check remote server session
|
|
|
++ $self->attr("session-id", $sid);
|
|
|
++ $self->validate(1);
|
|
|
++ if ($action_old eq "login" and $self->attr("session-valid") ne "yes") {
|
|
|
++ $self->error("server session still invalid after login: \"%s\"", $sid);
|
|
|
++ return 0;
|
|
|
++ }
|
|
|
++ elsif ($action_old eq "logout" and $self->attr("session-valid") ne "no") {
|
|
|
++ $self->error("server session still valid after logout: \"%s\"", $sid);
|
|
|
++ return 0;
|
|
|
++ }
|
|
|
++
|
|
|
++ # redirect to own following URL
|
|
|
++ my $mode_after = $self->attr("mode-after");
|
|
|
++ my $url = sprintf("%s?%s=%s", $self->{-cgi}->url(-relative => 1), $self->{-mode}, $mode_after);
|
|
|
++ $self->response($self->{-cgi}->redirect(-url => $url, -status => 302));
|
|
|
++ return 1;
|
|
|
++ }
|
|
|
++ else {
|
|
|
++ $self->error("unable to determine action");
|
|
|
++ return 0;
|
|
|
++ }
|
|
|
++}
|
|
|
++
|
|
|
++sub response ($;$) {
|
|
|
++ my ($self, $response) = @_;
|
|
|
++
|
|
|
++ my $rv = $self->{-response};
|
|
|
++ if (not $rv and $self->error()) {
|
|
|
++ $rv = $self->{-cgi}->header(
|
|
|
++ -status => "500 Internal Server Error",
|
|
|
++ -type => "text/plain",
|
|
|
++ -expires => "+0s",
|
|
|
++ ) . "ASE ERROR: " . $self->error() . "\n";
|
|
|
++ }
|
|
|
++ $self->{-response} = $response if (@_ == 2);
|
|
|
++ return $rv;
|
|
|
++}
|
|
|
++
|
|
|
++sub error ($;$@) {
|
|
|
++ my ($self, $fmt, @args) = @_;
|
|
|
++
|
|
|
++ my $rv = $self->{-error};
|
|
|
++ $self->{-error} = (@_ >= 3 ? sprintf($fmt, @args) : sprintf("%s", $fmt)) if (@_ >= 2);
|
|
|
++ return $rv;
|
|
|
++}
|
|
|
++
|
|
|
++# session validation
|
|
|
++sub validate ($) {
|
|
|
++ my ($self, $forced) = @_;
|
|
|
++
|
|
|
++ # make sure there is a session to be validated
|
|
|
++ my $sid = $self->attr("session-id");
|
|
|
++ return if (not defined($sid));
|
|
|
++
|
|
|
++ # debugging
|
|
|
++ $self->_debug("METHOD: validate: forced=%s sid=%s", $forced ? "yes" : "no", $sid);
|
|
|
++
|
|
|
++ # short-circuit if still no (re-)validation is necessary
|
|
|
++ my $valid_since = $self->attr("session-valid-since");
|
|
|
++ return if ( not $forced
|
|
|
++ and defined($valid_since)
|
|
|
++ and ( $self->{-valid} == 0
|
|
|
++ or ($valid_since + $self->{-valid}) > time()));
|
|
|
++
|
|
|
++ # clear all remembered session attributes
|
|
|
++ foreach my $key (@valid_attributes) {
|
|
|
++ $self->attr($key, undef);
|
|
|
++ }
|
|
|
++
|
|
|
++ # query server for session information
|
|
|
++ $self->_use("IO::Socket::INET");
|
|
|
++ my $server = $self->{-server};
|
|
|
++ my ($host, $port, $path) = ($server =~ m|^http://([^:/]+)((?::\d+)?)(.*)$|) or die;
|
|
|
++ $port ||= 80;
|
|
|
++ $port =~ s|^:||;
|
|
|
++ $path .= "?mode=rpc;method=info;sid=$sid";
|
|
|
++ my $sock = IO::Socket::INET->new (
|
|
|
++ PeerAddr => $host,
|
|
|
++ PeerPort => $port,
|
|
|
++ Proto => "tcp",
|
|
|
++ Timeout => 10
|
|
|
++ ) or die "failed to connect to $host:$port: $@";
|
|
|
++ $sock->autoflush(1);
|
|
|
++ $sock->printf(
|
|
|
++ "GET $path HTTP/1.0\n" .
|
|
|
++ "Host: $host:$port\n" .
|
|
|
++ "\n"
|
|
|
++ );
|
|
|
++ my $response = '';
|
|
|
++ $response .= $_ while (<$sock>);
|
|
|
++ $sock->close();
|
|
|
++ $self->_debug("METHOD: validate: response from %s", $server);
|
|
|
++
|
|
|
++ # parse session information response
|
|
|
++ my $attribute = {};
|
|
|
++ $response =~ s|^HTTP/1.[01x]\s+200\s+.+?\r?\n\r?\n||s;
|
|
|
++ foreach my $key (@valid_attributes) {
|
|
|
++ $attribute->{$key} = "";
|
|
|
++ $response =~ s|${key}:[ \t]+([^\r\n]+)\r?\n|$attribute->{$key} = $1, ''|sei;
|
|
|
++ }
|
|
|
++
|
|
|
++ # check validatity of session
|
|
|
++ my $expires = ($attribute->{"session-expires"} || 0) - time();
|
|
|
++ if (not ( $attribute->{"session-valid"} eq "yes"
|
|
|
++ and $attribute->{"client-login-uuid"} ne ""
|
|
|
++ and $attribute->{"client-login-name"} ne ""
|
|
|
++ and $expires > 0 )) {
|
|
|
++ $attribute->{"session-valid"} = "no";
|
|
|
++ $attribute->{"session-expires"} = time()+1;
|
|
|
++ $expires = 1;
|
|
|
++ }
|
|
|
++
|
|
|
++ # take over session attributes
|
|
|
++ foreach my $key (@valid_attributes) {
|
|
|
++ $self->attr($key, $attribute->{$key}, sprintf("+%ds", $expires));
|
|
|
++ }
|
|
|
++
|
|
|
++ # remember time of this validation
|
|
|
++ $self->attr("session-valid-since", time());
|
|
|
++ $self->_dump("validate: ", $self->{-session});
|
|
|
++ return;
|
|
|
++}
|
|
|
++
|
|
|
++# self-referencing URL generator
|
|
|
++sub url ($%) {
|
|
|
++ my ($self, %args) = @_;
|
|
|
++
|
|
|
++ # create self-referencing URL
|
|
|
++ my $base = $self->{-cgi}->url(-relative => 1);
|
|
|
++ $base = '.' if ($base eq '');
|
|
|
++ my $mode = $self->{-cgi}->url_param($self->{-mode})
|
|
|
++ || $self->{-cgi}->param($self->{-mode})
|
|
|
++ || "";
|
|
|
++ my $url = sprintf(
|
|
|
++ "%s?ase-action=%s;ase-mode-during=%s;ase-mode-after=%s",
|
|
|
++ $base, $args{-action},
|
|
|
++ $args{-mode_during} || $mode,
|
|
|
++ $args{-mode_after} || $mode
|
|
|
++ );
|
|
|
++
|
|
|
++ return $url;
|
|
|
++}
|
|
|
++
|
|
|
++# return arbitrary ASE session attributes
|
|
|
++sub attr ($$;$$) {
|
|
|
++ my ($self, $name, $value, $expire) = @_;
|
|
|
++
|
|
|
++ my $value_old = $self->{-session}->param("ase-$name");
|
|
|
++ if (@_ >= 3) {
|
|
|
++ if (defined($value)) {
|
|
|
++ $self->{-session}->param("ase-$name", $value);
|
|
|
++ if (defined($expire)) {
|
|
|
++ $self->{-session}->expire("ase-$name", $expire);
|
|
|
++ }
|
|
|
++ }
|
|
|
++ else {
|
|
|
++ $self->{-session}->clear("ase-$name");
|
|
|
++ }
|
|
|
++ }
|
|
|
++ return $value_old;
|
|
|
++}
|
|
|
++
|
|
|
++# return current login
|
|
|
++sub login ($) {
|
|
|
++ my ($self) = @_;
|
|
|
++
|
|
|
++ return (($self->attr("session-valid") || "no") eq "yes");
|
|
|
++}
|
|
|
++
|
|
|
++# return ASE canvas marker for head and body
|
|
|
++sub canvas ($%) {
|
|
|
++ my ($self, %args) = @_;
|
|
|
++
|
|
|
++ return ( $args{-part} eq 'head'
|
|
|
++ ? $canvas_mark->{"head"}
|
|
|
++ : $canvas_mark->{"body"});
|
|
|
++}
|
|
|
++
|
|
|
++1;
|
|
|
++
|
|
|
++__END__
|
|
|
++
|
|
|
++=pod
|
|
|
++
|
|
|
++=head1 NAME
|
|
|
++
|
|
|
++OSSP::ase::client -- OSSP ase Client API
|
|
|
++
|
|
|
++=head1 DESCRIPTION
|
|
|
++
|
|
|
++B<OSSP::ase::client> is the client Perl API of B<OSSP ase>.
|
|
|
++It allows an arbitrary CGI written in Perl to leverage from
|
|
|
++B<OSSP ase> authentication.
|
|
|
++
|
|
|
++=head1 APPLICATION PROGRAMMING INTERFACE (API)
|
|
|
++
|
|
|
++The following API methods are provided:
|
|
|
++
|
|
|
++=over 4
|
|
|
++
|
|
|
++=item C<my $ase = >B<new OSSP::ase::client>C<(>I<options>C<);>
|
|
|
++
|
|
|
++This creates a new B<OSSP ase> client object.
|
|
|
++The available I<options> are:
|
|
|
++
|
|
|
++=over 4
|
|
|
++
|
|
|
++=item B<-server> (default: I<none>)
|
|
|
++
|
|
|
++Mandatory URL of the B<OSSP ase> server CGI.
|
|
|
++Usually something like C<http://ase.example.com/ase.cgi>".
|
|
|
++
|
|
|
++=item B<-cgi> (default: C<new CGI>)
|
|
|
++
|
|
|
++Optional but strongly recommended reference to a B<CGI> query object.
|
|
|
++
|
|
|
++=item B<-session> (default: C<new CGI::Session>)
|
|
|
++
|
|
|
++Optional but strongly recommended reference to a B<CGI::Session> session
|
|
|
++handling object.
|
|
|
++
|
|
|
++=item B<-mode> (default: C<"mode">)
|
|
|
++
|
|
|
++Optional name of B<CGI> parameter holding the run-time mode
|
|
|
++dispatching information, i.e., the parameter your application
|
|
|
++uses to decide which application screen/page to display.
|
|
|
++
|
|
|
++=item B<-valid> (default: C<0>)
|
|
|
++
|
|
|
++Optional number of seconds a B<OSSP ase> server session information is
|
|
|
++valid before it is forced to be revalidated. A value of C<0> indicates
|
|
|
++that no revalidation is enforced at all. Nevertheless the B<OSSP ase>
|
|
|
++server session information is automatically expiring after the time
|
|
|
++the server indicated. The revalidated is intended for intermediate
|
|
|
++revalidation.
|
|
|
++
|
|
|
++=back
|
|
|
++
|
|
|
++=item C<$ase-E<gt>destroy();>
|
|
|
++
|
|
|
++=item C<undef $ase;>
|
|
|
++
|
|
|
++This destroys the B<OSSP ase> client object.
|
|
|
++
|
|
|
++=item C<$ase-E<gt>responsible();>
|
|
|
++
|
|
|
++FIXME
|
|
|
++
|
|
|
++=item C<$ase-E<gt>action();>
|
|
|
++
|
|
|
++FIXME
|
|
|
++
|
|
|
++=item C<$ase-E<gt>error();>
|
|
|
++
|
|
|
++FIXME
|
|
|
++
|
|
|
++=item C<$ase-E<gt>response();>
|
|
|
++
|
|
|
++FIXME
|
|
|
++
|
|
|
++=item C<$ase-E<gt>validate($forced);>
|
|
|
++
|
|
|
++FIXME
|
|
|
++
|
|
|
++=item C<$ase-E<gt>url();>
|
|
|
++
|
|
|
++FIXME
|
|
|
++
|
|
|
++=item C<$ase-E<gt>attr($name>[C<, $value>[C<, $expire>]]C<);>
|
|
|
++
|
|
|
++FIXME
|
|
|
++
|
|
|
++=item C<$ase-E<gt>canvas();>
|
|
|
++
|
|
|
++FIXME
|
|
|
++
|
|
|
++=back
|
|
|
++
|
|
|
++=cut
|
|
|
++
|
