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