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