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