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      my %binary_to_source_cache;
 131      for my $bug (@bugs) {
 132           my $bug_status;
 133           if (ref($bug)) {
 134                my %param = __collapse_params(@{$bug});
 135                next unless defined $param{bug};
 136                $bug = $param{bug};
 137                $bug_status = get_bug_status(map {(exists $param{$_})?($_,$param{$_}):()}
 138                                             qw(bug dist arch bugusertags sourceversions version indicatesource),
 139                                             binary_to_source_cache => \%binary_to_source_cache,
 140                                            );
 141           }
 142           else {
 143               $bug_status = get_bug_status(bug => $bug,
 144                                            binary_to_source_cache => \%binary_to_source_cache,
 145                                           );
 146           }
 147           if (defined $bug_status and keys %{$bug_status} > 0) {
 148                $status{$bug}  = $bug_status;
 149           }
 150      }
 151 #     __prepare_response($self);
 152      return encode_utf8_structure(\%status);
 153 }
 154
 155 =head2 get_bugs
 156
 157      my @bugs = get_bugs(...);
 158      my @bugs = get_bugs([...]);
 159
 160 Returns a list of bugs. In the second case, allows the variable
 161 parameters to be specified as an array reference in case your favorite
 162 language's SOAP implementation is craptacular.
 163
 164 See L<Debbugs::Bugs::get_bugs> for details on what C<...> actually
 165 means.
 166
 167 =cut
 168
 169 use Debbugs::Bugs qw();
 170
 171 sub get_bugs{
 172      my $VERSION = __populate_version(pop);
 173      my ($self,@params) = @_;
 174      # Because some soap implementations suck and can't handle
 175      # variable numbers of arguments we allow get_bugs([]);
 176      if (@params == 1 and ref($params[0]) eq 'ARRAY') {
 177           @params = @{$params[0]};
 178      }
 179      my %params = __collapse_params(@params);
 180      my @bugs;
 181      @bugs = Debbugs::Bugs::get_bugs(%params);
 182      return encode_utf8_structure(\@bugs);
 183 }
 184
 185 =head2 newest_bugs
 186
 187      my @bugs = newest_bugs(5);
 188
 189 Returns a list of the newest bugs. [Note that all bugs are *not*
 190 guaranteed to exist, but they should in the most common cases.]
 191
 192 =cut
 193
 194 sub newest_bugs{
 195      my $VERSION = __populate_version(pop);
 196      my ($self,$num) = @_;
 197      my $newest_bug = Debbugs::Bugs::newest_bug();
 198      return encode_utf8_structure([($newest_bug - $num + 1) .. $newest_bug]);
 199
 200 }
 201
 202 =head2 get_bug_log
 203
 204      my $bug_log = get_bug_log($bug);
 205      my $bug_log = get_bug_log($bug,$msg_num);
 206
 207 Retuns a parsed set of the bug log; this is an array of hashes with
 208 the following
 209
 210  [{html => '',
 211    header => '',
 212    body    => '',
 213    attachments => [],
 214    msg_num     => 5,
 215   },
 216   {html => '',
 217    header => '',
 218    body    => '',
 219    attachments => [],
 220   },
 221  ]
 222
 223
 224 Currently $msg_num is completely ignored.
 225
 226 =cut
 227
 228 use Debbugs::Log qw();
 229 use Debbugs::MIME qw(parse);
 230
 231 sub get_bug_log{
 232      my $VERSION = __populate_version(pop);
 233      my ($self,$bug,$msg_num) = @_;
 234
 235      my $log = Debbugs::Log->new(bug_num => $bug) or
 236           die "Debbugs::Log was unable to be initialized";
 237
 238      my %seen_msg_ids;
 239      my $current_msg=0;
 240      my @messages;
 241      while (my $record = $log->read_record()) {
 242           $current_msg++;
 243           #next if defined $msg_num and ($current_msg ne $msg_num);
 244           next unless $record->{type} eq 'incoming-recv';
 245           my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
 246           next if defined $msg_id and exists $seen_msg_ids{$msg_id};
 247           $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
 248           next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
 249           my $message = parse($record->{text});
 250           my ($header,$body) = map {join("\n",make_list($_))}
 251                @{$message}{qw(header body)};
 252           push @messages,{header => $header,
 253                           body   => $body,
 254                           attachments => [],
 255                           msg_num => $current_msg,
 256                          };
 257      }
 258      return encode_utf8_structure(\@messages);
 259 }
 260
 261 =head2 binary_to_source
 262
 263      binary_to_source($binary_name,$binary_version,$binary_architecture)
 264
 265 Returns a reference to the source package name and version pair
 266 corresponding to a given binary package name, version, and
 267 architecture. If undef is passed as the architecture, returns a list
 268 of references to all possible pairs of source package names and
 269 versions for all architectures, with any duplicates removed.
 270
 271 As of comaptibility version 2, this has changed to use the more
 272 powerful binary_to_source routine, which allows returning source only,
 273 concatenated scalars, and other useful features.
 274
 275 See the documentation of L<Debbugs::Packages::binary_to_source> for
 276 details.
 277
 278 =cut
 279
 280 sub binary_to_source{
 281      my $VERSION = __populate_version(pop);
 282      my ($self,@params) = @_;
 283
 284      if ($VERSION <= 1) {
 285          return encode_utf8_structure([Debbugs::Packages::binary_to_source(binary => $params[0],
 286                                                      (@params > 1)?(version => $params[1]):(),
 287                                                      (@params > 2)?(arch    => $params[2]):(),
 288                                                     )]);
 289      }
 290      else {
 291          return encode_utf8_structure([Debbugs::Packages::binary_to_source(@params)]);
 292      }
 293 }
 294
 295 =head2 source_to_binary
 296
 297      source_to_binary($source_name,$source_version);
 298
 299 Returns a reference to an array of references to binary package name,
 300 version, and architecture corresponding to a given source package name
 301 and version. In the case that the given name and version cannot be
 302 found, the unversioned package to source map is consulted, and the
 303 architecture is not returned.
 304
 305 (This function corresponds to L<Debbugs::Packages::sourcetobinary>)
 306
 307 =cut
 308
 309 sub source_to_binary {
 310      my $VERSION = __populate_version(pop);
 311      my ($self,@params) = @_;
 312
 313      return encode_utf8_structure([Debbugs::Packages::sourcetobinary(@params)]);
 314 }
 315
 316 =head2 get_versions
 317
 318      get_version(package=>'foopkg',
 319                  dist => 'unstable',
 320                  arch => 'i386',
 321                 );
 322
 323 Returns a list of the versions of package in the distributions and
 324 architectures listed. This routine only returns unique values.
 325
 326 =over
 327
 328 =item package -- package to return list of versions
 329
 330 =item dist -- distribution (unstable, stable, testing); can be an
 331 arrayref
 332
 333 =item arch -- architecture (i386, source, ...); can be an arrayref
 334
 335 =item time -- returns a version=>time hash at which the newest package
 336 matching this version was uploaded
 337
 338 =item source -- returns source/version instead of just versions
 339
 340 =item no_source_arch -- discards the source architecture when arch is
 341 not passed. [Used for finding the versions of binary packages only.]
 342 Defaults to 0, which does not discard the source architecture. (This
 343 may change in the future, so if you care, please code accordingly.)
 344
 345 =item return_archs -- returns a version=>[archs] hash indicating which
 346 architectures are at which versions.
 347
 348 =back
 349
 350 This function corresponds to L<Debbugs::Packages::get_versions>
 351
 352 =cut
 353
 354 sub get_versions{
 355      my $VERSION = __populate_version(pop);
 356      my ($self,@params) = @_;
 357
 358      return encode_utf8_structure(scalar Debbugs::Packages::get_versions(@params));
 359 }
 360
 361 =head1 VERSION COMPATIBILITY
 362
 363 The functionality provided by the SOAP interface will change over time.
 364
 365 To the greatest extent possible, we will attempt to provide backwards
 366 compatibility with previous versions; however, in order to have
 367 backwards compatibility, you need to specify the version with which
 368 you are compatible.
 369
 370 =cut
 371
 372 sub __populate_version{
 373      my ($request) = @_;
 374      return $request->{___debbugs_soap_version};
 375 }
 376
 377 sub __collapse_params{
 378      my @params = @_;
 379
 380      my %params;
 381      # Because some clients can't handle passing arrayrefs, we allow
 382      # options to be specified multiple times
 383      while (my ($key,$value) = splice @params,0,2) {
 384           push @{$params{$key}}, make_list($value);
 385      }
 386      # However, for singly specified options, we want to pull them
 387      # back out
 388      for my $key (keys %params) {
 389           if (@{$params{$key}} == 1) {
 390                ($params{$key}) = @{$params{$key}}
 391           }
 392      }
 393      return %params;
 394 }
 395
 396
 397 1;
 398
 399
 400 __END__
 401
 402
 403
 404
 405
 406