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]} <= 1 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                $bug_status = get_bug_status(map {(exists $param{$_})?($_,$param{$_}):()}
 132                                             qw(bug dist arch bugusertags sourceversions version)
 133                                            );
 134           }
 135           else {
 136                $bug_status = get_bug_status(bug => $bug);
 137           }
 138           if (defined $bug_status and keys %{$bug_status} > 0) {
 139                $status{$bug}  = $bug_status;
 140           }
 141      }
 142 #     __prepare_response($self);
 143      return \%status;
 144 }
 145
 146 =head2 get_bugs
 147
 148      my @bugs = get_bugs(...);
 149      my @bugs = get_bugs([...]);
 150
 151 Returns a list of bugs. In the second case, allows the variable
 152 parameters to be specified as an array reference in case your favorite
 153 language's SOAP implementation is craptacular.
 154
 155 See L<Debbugs::Bugs::get_bugs> for details on what C<...> actually
 156 means.
 157
 158 =cut
 159
 160 use Debbugs::Bugs qw();
 161
 162 sub get_bugs{
 163      my $VERSION = __populate_version(pop);
 164      my ($self,@params) = @_;
 165      # Because some soap implementations suck and can't handle
 166      # variable numbers of arguments we allow get_bugs([]);
 167      if (@params == 1 and ref($params[0]) eq 'ARRAY') {
 168           @params = @{$params[0]};
 169      }
 170      my %params = __collapse_params(@params);
 171      my @bugs;
 172      @bugs = Debbugs::Bugs::get_bugs(%params);
 173      return \@bugs;
 174 }
 175
 176 =head2 newest_bugs
 177
 178      my @bugs = newest_bugs(5);
 179
 180 Returns a list of the newest bugs. [Note that all bugs are *not*
 181 guaranteed to exist, but they should in the most common cases.]
 182
 183 =cut
 184
 185 sub newest_bugs{
 186      my $VERSION = __populate_version(pop);
 187      my ($self,$num) = @_;
 188      my $newest_bug = Debbugs::Bugs::newest_bug();
 189      return [($newest_bug - $num + 1) .. $newest_bug];
 190
 191 }
 192
 193 =head2 get_bug_log
 194
 195      my $bug_log = get_bug_log($bug);
 196      my $bug_log = get_bug_log($bug,$msg_num);
 197
 198 Retuns a parsed set of the bug log; this is an array of hashes with
 199 the following
 200
 201  [{html => '',
 202    header => '',
 203    body    => '',
 204    attachments => [],
 205    msg_num     => 5,
 206   },
 207   {html => '',
 208    header => '',
 209    body    => '',
 210    attachments => [],
 211   },
 212  ]
 213
 214
 215 Currently $msg_num is completely ignored.
 216
 217 =cut
 218
 219 use Debbugs::Log qw();
 220 use Debbugs::MIME qw(parse);
 221
 222 sub get_bug_log{
 223      my $VERSION = __populate_version(pop);
 224      my ($self,$bug,$msg_num) = @_;
 225
 226      my $location = getbuglocation($bug,'log');
 227      my $bug_log = getbugcomponent($bug,'log',$location);
 228
 229      my $log_fh = IO::File->new($bug_log, 'r') or
 230           die "Unable to open bug log $bug_log for reading: $!";
 231
 232      my $log = Debbugs::Log->new($log_fh) or
 233           die "Debbugs::Log was unable to be initialized";
 234
 235      my %seen_msg_ids;
 236      my $current_msg=0;
 237      my $status = {};
 238      my @messages;
 239      while (my $record = $log->read_record()) {
 240           $current_msg++;
 241           #next if defined $msg_num and ($current_msg ne $msg_num);
 242           next unless $record->{type} eq 'incoming-recv';
 243           my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
 244           next if defined $msg_id and exists $seen_msg_ids{$msg_id};
 245           $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
 246           next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
 247           my $message = parse($record->{text});
 248           my ($header,$body) = map {join("\n",make_list($_))}
 249                @{$message}{qw(header body)};
 250           push @messages,{header => $header,
 251                           body   => $body,
 252                           attachments => [],
 253                           msg_num => $current_msg,
 254                          };
 255      }
 256      return \@messages;
 257 }
 258
 259
 260 =head1 VERSION COMPATIBILITY
 261
 262 The functionality provided by the SOAP interface will change over time.
 263
 264 To the greatest extent possible, we will attempt to provide backwards
 265 compatibility with previous versions; however, in order to have
 266 backwards compatibility, you need to specify the version with which
 267 you are compatible.
 268
 269 =cut
 270
 271 sub __populate_version{
 272      my ($request) = @_;
 273      return $request->{___debbugs_soap_version};
 274 }
 275
 276 sub __collapse_params{
 277      my @params = @_;
 278
 279      my %params;
 280      # Because some clients can't handle passing arrayrefs, we allow
 281      # options to be specified multiple times
 282      while (my ($key,$value) = splice @params,0,2) {
 283           push @{$params{$key}}, make_list($value);
 284      }
 285      # However, for singly specified options, we want to pull them
 286      # back out
 287      for my $key (keys %params) {
 288           if (@{$params{$key}} == 1) {
 289                ($params{$key}) = @{$params{$key}}
 290           }
 291      }
 292      return %params;
 293 }
 294
 295
 296 1;
 297
 298
 299 __END__
 300
 301
 302
 303
 304
 305