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