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