]> git.donarmstrong.com Git - debbugs.git/blob - Debbugs/SOAP.pm
fix how e-mails are passed to the avatar script
[debbugs.git] / Debbugs / SOAP.pm
1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later version at your option.
3 # See the file README and COPYING for more information.
4 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
5
6 package Debbugs::SOAP;
7
8 =head1 NAME
9
10 Debbugs::SOAP --
11
12 =head1 SYNOPSIS
13
14
15 =head1 DESCRIPTION
16
17
18 =head1 BUGS
19
20 None known.
21
22 =cut
23
24 use warnings;
25 use strict;
26 use vars qw($DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
27 use Debbugs::SOAP::Server;
28 use base qw(Exporter SOAP::Server::Parameters);
29
30 BEGIN{
31      $DEBUG = 0 unless defined $DEBUG;
32
33      @EXPORT = ();
34      %EXPORT_TAGS = (
35                     );
36      @EXPORT_OK = ();
37      Exporter::export_ok_tags();
38      $EXPORT_TAGS{all} = [@EXPORT_OK];
39
40 }
41
42 use IO::File;
43 use Debbugs::Status qw(get_bug_status);
44 use Debbugs::Common qw(make_list getbuglocation getbugcomponent);
45 use Debbugs::UTF8;
46 use Debbugs::Packages;
47
48 use Storable qw(nstore retrieve dclone);
49 use Scalar::Util qw(looks_like_number);
50
51
52 our $CURRENT_VERSION = 2;
53
54 =head2 get_usertag
55
56      my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug');
57      my %ut = get_usertag('don@donarmstrong.com');
58
59 Returns a hashref of bugs which have the specified usertags for the
60 user set.
61
62 In the second case, returns all of the usertags for the user passed.
63
64 =cut
65
66 use Debbugs::User qw(read_usertags);
67
68 sub get_usertag {
69      my $VERSION = __populate_version(pop);
70      my ($self,$email, @tags) = @_;
71      my %ut = ();
72      read_usertags(\%ut, $email);
73      my %tags;
74      @tags{@tags} = (1) x @tags;
75      if (keys %tags > 0) {
76           for my $tag (keys %ut) {
77                delete $ut{$tag} unless exists $tags{$tag};
78           }
79      }
80      return encode_utf8_structure(\%ut);
81 }
82
83
84 use Debbugs::Status;
85
86 =head2 get_status 
87
88      my @statuses = get_status(@bugs);
89      my @statuses = get_status([bug => 304234,
90                                 dist => 'unstable',
91                                ],
92                                [bug => 304233,
93                                 dist => 'unstable',
94                                ],
95                               )
96
97 Returns an arrayref of hashrefs which output the status for specific
98 sets of bugs.
99
100 In the first case, no options are passed to
101 L<Debbugs::Status::get_bug_status> besides the bug number; in the
102 second the bug, dist, arch, bugusertags, sourceversions, and version
103 parameters are passed if they are present.
104
105 As a special case for suboptimal SOAP implementations, if only one
106 argument is passed to get_status and it is an arrayref which either is
107 empty, has a number as the first element, or contains an arrayref as
108 the first element, the outer arrayref is dereferenced, and processed
109 as in the examples above.
110
111 See L<Debbugs::Status::get_bug_status> for details.
112
113 =cut
114
115 sub get_status {
116      my $VERSION = __populate_version(pop);
117      my ($self,@bugs) = @_;
118
119      if (@bugs == 1 and
120          ref($bugs[0]) and
121          (@{$bugs[0]} == 0 or
122           ref($bugs[0][0]) or
123           looks_like_number($bugs[0][0])
124          )
125         ) {
126               @bugs = @{$bugs[0]};
127      }
128      my %status;
129      for my $bug (@bugs) {
130           my $bug_status;
131           if (ref($bug)) {
132                my %param = __collapse_params(@{$bug});
133                next unless defined $param{bug};
134                $bug = $param{bug};
135                $bug_status = get_bug_status(map {(exists $param{$_})?($_,$param{$_}):()}
136                                             qw(bug dist arch bugusertags sourceversions version indicatesource)
137                                            );
138           }
139           else {
140                $bug_status = get_bug_status(bug => $bug);
141           }
142           if (defined $bug_status and keys %{$bug_status} > 0) {
143                $status{$bug}  = $bug_status;
144           }
145      }
146 #     __prepare_response($self);
147      return encode_utf8_structure(\%status);
148 }
149
150 =head2 get_bugs
151
152      my @bugs = get_bugs(...);
153      my @bugs = get_bugs([...]);
154
155 Returns a list of bugs. In the second case, allows the variable
156 parameters to be specified as an array reference in case your favorite
157 language's SOAP implementation is craptacular.
158
159 See L<Debbugs::Bugs::get_bugs> for details on what C<...> actually
160 means.
161
162 =cut
163
164 use Debbugs::Bugs qw();
165
166 sub get_bugs{
167      my $VERSION = __populate_version(pop);
168      my ($self,@params) = @_;
169      # Because some soap implementations suck and can't handle
170      # variable numbers of arguments we allow get_bugs([]);
171      if (@params == 1 and ref($params[0]) eq 'ARRAY') {
172           @params = @{$params[0]};
173      }
174      my %params = __collapse_params(@params);
175      my @bugs;
176      @bugs = Debbugs::Bugs::get_bugs(%params);
177      return encode_utf8_structure(\@bugs);
178 }
179
180 =head2 newest_bugs
181
182      my @bugs = newest_bugs(5);
183
184 Returns a list of the newest bugs. [Note that all bugs are *not*
185 guaranteed to exist, but they should in the most common cases.]
186
187 =cut
188
189 sub newest_bugs{
190      my $VERSION = __populate_version(pop);
191      my ($self,$num) = @_;
192      my $newest_bug = Debbugs::Bugs::newest_bug();
193      return encode_utf8_structure([($newest_bug - $num + 1) .. $newest_bug]);
194
195 }
196
197 =head2 get_bug_log
198
199      my $bug_log = get_bug_log($bug);
200      my $bug_log = get_bug_log($bug,$msg_num);
201
202 Retuns a parsed set of the bug log; this is an array of hashes with
203 the following
204
205  [{html => '',
206    header => '',
207    body    => '',
208    attachments => [],
209    msg_num     => 5,
210   },
211   {html => '',
212    header => '',
213    body    => '',
214    attachments => [],
215   },
216  ]
217
218
219 Currently $msg_num is completely ignored.
220
221 =cut
222
223 use Debbugs::Log qw();
224 use Debbugs::MIME qw(parse);
225
226 sub get_bug_log{
227      my $VERSION = __populate_version(pop);
228      my ($self,$bug,$msg_num) = @_;
229
230      my $log = Debbugs::Log->new(bug_num => $bug) or
231           die "Debbugs::Log was unable to be initialized";
232
233      my %seen_msg_ids;
234      my $current_msg=0;
235      my $status = {};
236      my @messages;
237      while (my $record = $log->read_record()) {
238           $current_msg++;
239           #next if defined $msg_num and ($current_msg ne $msg_num);
240           next unless $record->{type} eq 'incoming-recv';
241           my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
242           next if defined $msg_id and exists $seen_msg_ids{$msg_id};
243           $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
244           next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
245           my $message = parse($record->{text});
246           my ($header,$body) = map {join("\n",make_list($_))}
247                @{$message}{qw(header body)};
248           push @messages,{header => $header,
249                           body   => $body,
250                           attachments => [],
251                           msg_num => $current_msg,
252                          };
253      }
254      return encode_utf8_structure(\@messages);
255 }
256
257 =head2 binary_to_source
258
259      binary_to_source($binary_name,$binary_version,$binary_architecture)
260
261 Returns a reference to the source package name and version pair
262 corresponding to a given binary package name, version, and
263 architecture. If undef is passed as the architecture, returns a list
264 of references to all possible pairs of source package names and
265 versions for all architectures, with any duplicates removed.
266
267 As of comaptibility version 2, this has changed to use the more
268 powerful binary_to_source routine, which allows returning source only,
269 concatenated scalars, and other useful features.
270
271 See the documentation of L<Debbugs::Packages::binary_to_source> for
272 details.
273
274 =cut
275
276 sub binary_to_source{
277      my $VERSION = __populate_version(pop);
278      my ($self,@params) = @_;
279
280      if ($VERSION <= 1) {
281          return encode_utf8_structure([Debbugs::Packages::binary_to_source(binary => $params[0],
282                                                      (@params > 1)?(version => $params[1]):(),
283                                                      (@params > 2)?(arch    => $params[2]):(),
284                                                     )]);
285      }
286      else {
287          return encode_utf8_structure([Debbugs::Packages::binary_to_source(@params)]);
288      }
289 }
290
291 =head2 source_to_binary
292
293      source_to_binary($source_name,$source_version);
294
295 Returns a reference to an array of references to binary package name,
296 version, and architecture corresponding to a given source package name
297 and version. In the case that the given name and version cannot be
298 found, the unversioned package to source map is consulted, and the
299 architecture is not returned.
300
301 (This function corresponds to L<Debbugs::Packages::sourcetobinary>)
302
303 =cut
304
305 sub source_to_binary {
306      my $VERSION = __populate_version(pop);
307      my ($self,@params) = @_;
308
309      return encode_utf8_structure([Debbugs::Packages::sourcetobinary(@params)]);
310 }
311
312 =head2 get_versions
313
314      get_version(package=>'foopkg',
315                  dist => 'unstable',
316                  arch => 'i386',
317                 );
318
319 Returns a list of the versions of package in the distributions and
320 architectures listed. This routine only returns unique values.
321
322 =over
323
324 =item package -- package to return list of versions
325
326 =item dist -- distribution (unstable, stable, testing); can be an
327 arrayref
328
329 =item arch -- architecture (i386, source, ...); can be an arrayref
330
331 =item time -- returns a version=>time hash at which the newest package
332 matching this version was uploaded
333
334 =item source -- returns source/version instead of just versions
335
336 =item no_source_arch -- discards the source architecture when arch is
337 not passed. [Used for finding the versions of binary packages only.]
338 Defaults to 0, which does not discard the source architecture. (This
339 may change in the future, so if you care, please code accordingly.)
340
341 =item return_archs -- returns a version=>[archs] hash indicating which
342 architectures are at which versions.
343
344 =back
345
346 This function correponds to L<Debbugs::Packages::get_versions>
347
348 =cut
349
350 sub get_versions{
351      my $VERSION = __populate_version(pop);
352      my ($self,@params) = @_;
353
354      return encode_utf8_structure(scalar Debbugs::Packages::get_versions(@params));
355 }
356
357 =head1 VERSION COMPATIBILITY
358
359 The functionality provided by the SOAP interface will change over time.
360
361 To the greatest extent possible, we will attempt to provide backwards
362 compatibility with previous versions; however, in order to have
363 backwards compatibility, you need to specify the version with which
364 you are compatible.
365
366 =cut
367
368 sub __populate_version{
369      my ($request) = @_;
370      return $request->{___debbugs_soap_version};
371 }
372
373 sub __collapse_params{
374      my @params = @_;
375
376      my %params;
377      # Because some clients can't handle passing arrayrefs, we allow
378      # options to be specified multiple times
379      while (my ($key,$value) = splice @params,0,2) {
380           push @{$params{$key}}, make_list($value);
381      }
382      # However, for singly specified options, we want to pull them
383      # back out
384      for my $key (keys %params) {
385           if (@{$params{$key}} == 1) {
386                ($params{$key}) = @{$params{$key}}
387           }
388      }
389      return %params;
390 }
391
392
393 1;
394
395
396 __END__
397
398
399
400
401
402