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