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 corresponds 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