From 056a32a695142d3474b5b3183576e419ca5253e0 Mon Sep 17 00:00:00 2001 From: Don Armstrong Date: Wed, 20 Jun 2007 20:29:06 +0100 Subject: [PATCH] * Add the version aware soap subsystem * Add compatibility layer for the pre-existing soap queries * Add tests to verify that soap actually works --- Debbugs/SOAP.pm | 156 ++++++++++++++++++++++++++++++++++++++++ Debbugs/SOAP/Server.pm | 61 ++++++++++++++++ Debbugs/SOAP/Status.pm | 22 ------ Debbugs/SOAP/Usertag.pm | 18 ----- Debbugs/Status.pm | 2 +- cgi/soap.cgi | 17 +++-- t/09_soap.t | 105 +++++++++++++++++++++++++++ 7 files changed, 334 insertions(+), 47 deletions(-) create mode 100644 Debbugs/SOAP.pm create mode 100644 Debbugs/SOAP/Server.pm delete mode 100644 Debbugs/SOAP/Status.pm delete mode 100644 Debbugs/SOAP/Usertag.pm create mode 100644 t/09_soap.t diff --git a/Debbugs/SOAP.pm b/Debbugs/SOAP.pm new file mode 100644 index 00000000..58b41d20 --- /dev/null +++ b/Debbugs/SOAP.pm @@ -0,0 +1,156 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version at your option. +# See the file README and COPYING for more information. +# Copyright 2007 by Don Armstrong . + +package Debbugs::SOAP; + +=head1 NAME + +Debbugs::SOAP -- + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw($DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use base qw(Exporter SOAP::Server::Parameters); + +BEGIN{ + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = ( + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(); + $EXPORT_TAGS{all} = [@EXPORT_OK]; + +} + + +use Debbugs::Status qw(get_bug_status); +use Debbugs::Common qw(make_list); +use Storable qw(nstore retrieve); +use Debbugs::Cookies; + + +our $CURRENT_VERSION = 1; +our %DEBBUGS_SOAP_COOKIES; + + +=head2 get_usertag + + my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug'); + +Returns a hashref of bugs which have the specified usertags for the +user set. + +=cut + +use Debbugs::User qw(read_usertags); + +sub get_usertag { + my $VERSION = __populate_version(pop); + my ($self,$email, @tags) = @_; + my %ut = (); + read_usertags(\%ut, $email); + my %tags; + @tags{@tags} = (1) x @tags; + if (keys %tags > 0) { + for my $tag (keys %ut) { + delete $ut{$tag} unless exists $tags{$tag}; + } + } + return \%ut; +} + + +use Debbugs::Status; + +=head2 get_status + + my @statuses = get_status(@bugs); + +Returns an arrayref of hashrefs which output the status for specific +sets of bugs. + +See L for details. + +=cut + +sub get_status { + my $VERSION = __populate_version(pop); + my ($self,@bugs) = @_; + @bugs = make_list(@bugs); + + my %status; + for my $bug (@bugs) { + my $bug_status = get_bug_status(bug => $bug); + if (defined $bug_status and keys %{$bug_status} > 0) { + $status{$bug} = $bug_status; + } + } +# __prepare_response($self); + return \%status; +} + +=head2 get_bugs + + my @bugs = get_bugs(...); + +See L for details. + +=cut + +use Debbugs::Bugs qw(); + +sub get_bugs{ + my $VERSION = __populate_version(pop); + my ($self,@params) = @_; + my %params; + while (my ($key,$value) = splice @params,0,2) { + push @{$params{$key}}, $value; + } + my @bugs; + @bugs = Debbugs::Bugs::get_bugs(%params); + return \@bugs; +} + + +=head1 VERSION COMPATIBILITY + +The functionality provided by the SOAP interface will change over time. + +To the greatest extent possible, we will attempt to provide backwards +compatibility with previous versions; however, in order to have +backwards compatibility, you need to specify the version with which +you are compatible. + +=cut + +sub __populate_version{ + my ($request) = @_; + return $request->{___debbugs_soap_version}; +} + +1; + + +__END__ + + + + + + diff --git a/Debbugs/SOAP/Server.pm b/Debbugs/SOAP/Server.pm new file mode 100644 index 00000000..c55267b3 --- /dev/null +++ b/Debbugs/SOAP/Server.pm @@ -0,0 +1,61 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version at your option. +# See the file README and COPYING for more information. +# Copyright 2007 by Don Armstrong . + +package Debbugs::SOAP::Server; + +=head1 NAME + +Debbugs::SOAP::Server -- Server Transport module + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw(@ISA); +use SOAP::Transport::HTTP; +BEGIN{ + # Eventually we'll probably change this to just be HTTP::Server and + # have the soap.cgi declare a class which inherits from both + push @ISA,qw(SOAP::Transport::HTTP::CGI); +} + +use Debbugs::SOAP; + +sub find_target { + my ($self,$request) = @_; + + # WTF does this do? + $request->match((ref $request)->method); + my $method_uri = $request->namespaceuriof || 'Debbugs/SOAP'; + my $method_name = $request->dataof->name; + $method_uri =~ s{(?:/?Status/?|/?Usertag/?)}{}; + $method_uri =~ s{(Debbugs/SOAP/)[vV](\d+)/?}{$1}; + my ($soap_version) = $2 if defined $2; + $self->dispatched('Debbugs:::SOAP'); + $request->{___debbugs_soap_version} = $soap_version || ''; + return ('Debbugs::SOAP',$method_uri,$method_name); +} + + +1; + + +__END__ + + + + + + diff --git a/Debbugs/SOAP/Status.pm b/Debbugs/SOAP/Status.pm deleted file mode 100644 index b452eb07..00000000 --- a/Debbugs/SOAP/Status.pm +++ /dev/null @@ -1,22 +0,0 @@ -package Debbugs::SOAP::Status; - -# This is a hack that must be removed -require '/home/don/projects/debbugs/source/cgi/common.pl'; -#use Debbugs::Status qw(getbugstatus); - -sub get_status { - my ($class, @bugs) = @_; - @bugs = map {ref($_)?@{$_}:$_} @bugs; - - my %s; - foreach (@bugs) { - my $hash = getbugstatus($_); - if (scalar(%{$hash}) > 0) { - $s{$_} = $hash; - } - } - - return \%s; -} - -1; diff --git a/Debbugs/SOAP/Usertag.pm b/Debbugs/SOAP/Usertag.pm deleted file mode 100644 index 2ee7cea0..00000000 --- a/Debbugs/SOAP/Usertag.pm +++ /dev/null @@ -1,18 +0,0 @@ -package Debbugs::SOAP::Usertag; - -use Debbugs::User; - -sub get_usertag { - my ($class, $email, $tag) = @_; - my %ut = (); - Debbugs::User::read_usertags(\%ut, $email); - if (defined($tag) and $tag ne "") { - # Remove unwanted tags - foreach (keys %ut) { - delete $ut{$_} unless $_ eq $tag; - } - } - return \%ut; -} - -1; diff --git a/Debbugs/Status.pm b/Debbugs/Status.pm index 6911c32a..55ed9354 100644 --- a/Debbugs/Status.pm +++ b/Debbugs/Status.pm @@ -797,7 +797,7 @@ sub get_bug_status { } else { my $location = getbuglocation($param{bug}, 'summary'); - return {} if not length $location; + return {} if not defined $location or not length $location; %status = %{ readbug( $param{bug}, $location ) }; } $status{id} = $param{bug}; diff --git a/cgi/soap.cgi b/cgi/soap.cgi index 04d72652..0eea5e66 100755 --- a/cgi/soap.cgi +++ b/cgi/soap.cgi @@ -1,15 +1,20 @@ #!/usr/bin/perl -wT -package debbugs; - -use SOAP::Transport::HTTP; +#use SOAP::Transport::HTTP; use Debbugs::SOAP::Usertag; use Debbugs::SOAP::Status; +use Debbugs::SOAP::Server; + +# Work around stupid soap bug on line 411 +if (not exists $ENV{EXPECT}) { + $ENV{EXPECT} = ''; +} -my $soap = SOAP::Transport::HTTP::CGI - -> dispatch_to('Debbugs::SOAP::Usertag', 'Debbugs::SOAP::Status'); -$soap->serializer()->soapversion(1.2); +my $soap = Debbugs::SOAP::Server +#my $soap = SOAP::Transport::HTTP::CGI + -> dispatch_to('Debbugs::SOAP'); +#$soap->serializer()->soapversion(1.2); # soapy is stupid, and is using the 1999 schema; override it. *SOAP::XMLSchema1999::Serializer::as_base64Binary = \&SOAP::XMLSchema2001::Serializer::as_base64Binary; $soap-> handle; diff --git a/t/09_soap.t b/t/09_soap.t new file mode 100644 index 00000000..2ffd45c2 --- /dev/null +++ b/t/09_soap.t @@ -0,0 +1,105 @@ +# -*- mode: cperl;-*- + + +use Test::More tests => 4; + +use warnings; +use strict; + +# Here, we're going to shoot messages through a set of things that can +# happen. + +# First, we're going to send mesages to receive. +# To do so, we'll first send a message to submit, +# then send messages to the newly created bugnumber. + +use IO::File; +use File::Temp qw(tempdir); +use Cwd qw(getcwd); +use Debbugs::MIME qw(create_mime_message); +use File::Basename qw(dirname basename); +use Test::WWW::Mechanize; +# The test functions are placed here to make things easier +use lib qw(t/lib); +use DebbugsTest qw(:configuration); +use Cwd; + +my %config; +eval { + %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0); +}; +if ($@) { + BAIL_OUT($@); +} + +# Output some debugging information if there's an error +END{ + if ($ENV{DEBUG}) { + foreach my $key (keys %config) { + diag("$key: $config{$key}\n"); + } + } +} + +# create a bug +send_message(to=>'submit@bugs.something', + headers => [To => 'submit@bugs.something', + From => 'foo@bugs.something', + Subject => 'Submitting a bug', + ], + body => <new(LocalAddr => 'localhost', LocalPort => $port) + ->dispatch_to('/','Debbugs::SOAP') + ->handle; + ); +} + +use SOAP::Lite; +my $soap = SOAP::Lite->uri('Debbugs/SOAP')->proxy('http://localhost:'.$port.'/'); +#ok($soap->get_soap_version->result == 1,'Version set and got correctly'); +my $bugs = $soap->get_bugs(package => 'foo')->result; +use Data::Dumper; +ok(@{$bugs} == 1 && $bugs->[0] == 1, 'get_bugs returns bug number 1') or fail(Dumper($bugs)); +my $status = $soap->get_status(1)->result; +ok($status->{1}{package} eq 'foo','get_status thinks that bug 1 belongs in foo') or fail(Dumper($status)); + +# Test the usertags at some point -- 2.39.5