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
  47
  48 our $CURRENT_VERSION = 1;
  49
  50 =head2 get_usertag
  51
  52      my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug');
  53      my %ut = get_usertag('don@donarmstrong.com');
  54
  55 Returns a hashref of bugs which have the specified usertags for the
  56 user set.
  57
  58 In the second case, returns all of the usertags for the user passed.
  59
  60 =cut
  61
  62 use Debbugs::User qw(read_usertags);
  63
  64 sub get_usertag {
  65      my $VERSION = __populate_version(pop);
  66      my ($self,$email, @tags) = @_;
  67      my %ut = ();
  68      read_usertags(\%ut, $email);
  69      my %tags;
  70      @tags{@tags} = (1) x @tags;
  71      if (keys %tags > 0) {
  72           for my $tag (keys %ut) {
  73                delete $ut{$tag} unless exists $tags{$tag};
  74           }
  75      }
  76      return \%ut;
  77 }
  78
  79
  80 use Debbugs::Status;
  81
  82 =head2 get_status
  83
  84      my @statuses = get_status(@bugs);
  85      my @statuses = get_status([bug => 304234,
  86                                 dist => 'unstable',
  87                                ],
  88                                [bug => 304233,
  89                                 dist => 'unstable',
  90                                ],
  91                               )
  92
  93 Returns an arrayref of hashrefs which output the status for specific
  94 sets of bugs.
  95
  96 In the first case, no options are passed to
  97 L<Debbugs::Status::get_bug_status> besides the bug number; in the
  98 second the bug, dist, arch, bugusertags, sourceversions, and version
  99 parameters are passed if they are present.
 100
 101 See L<Debbugs::Status::get_bug_status> for details.
 102
 103 =cut
 104
 105 sub get_status {
 106      my $VERSION = __populate_version(pop);
 107      my ($self,@bugs) = @_;
 108
 109      my %status;
 110      for my $bug (@bugs) {
 111           my $bug_status;
 112           if (ref($bug)) {
 113                my %param = __collapse_params(@{$bug});
 114                $bug_status = get_bug_status(map {(exists $param{$_})?($_,$param{$_}):()}
 115                                             qw(bug dist arch bugusertags sourceversions version)
 116                                            );
 117           }
 118           else {
 119                $bug_status = get_bug_status(bug => $bug);
 120           }
 121           if (defined $bug_status and keys %{$bug_status} > 0) {
 122                $status{$bug}  = $bug_status;
 123           }
 124      }
 125 #     __prepare_response($self);
 126      return \%status;
 127 }
 128
 129 =head2 get_bugs
 130
 131      my @bugs = get_bugs(...);
 132      my @bugs = get_bugs([...]);
 133
 134 Returns a list of bugs. In the second case, allows the variable
 135 parameters to be specified as an array reference in case your favorite
 136 language's SOAP implementation is craptacular.
 137
 138 See L<Debbugs::Bugs::get_bugs> for details on what C<...> actually
 139 means.
 140
 141 =cut
 142
 143 use Debbugs::Bugs qw();
 144
 145 sub get_bugs{
 146      my $VERSION = __populate_version(pop);
 147      my ($self,@params) = @_;
 148      # Because some soap implementations suck and can't handle
 149      # variable numbers of arguments we allow get_bugs([]);
 150      if (@params == 1 and ref($params[0]) eq 'ARRAY') {
 151           @params = @{$params[0]};
 152      }
 153      my %params = __collapse_params(@params);
 154      my @bugs;
 155      @bugs = Debbugs::Bugs::get_bugs(%params);
 156      return \@bugs;
 157 }
 158
 159 =head2 newest_bugs
 160
 161      my @bugs = newest_bugs(5);
 162
 163 Returns a list of the newest bugs. [Note that all bugs are *not*
 164 guaranteed to exist, but they should in the most common cases.]
 165
 166 =cut
 167
 168 sub newest_bugs{
 169      my $VERSION = __populate_version(pop);
 170      my ($self,$num) = @_;
 171      my $newest_bug = Debbugs::Bugs::newest_bug();
 172      return [($newest_bug - $num + 1) .. $newest_bug];
 173
 174 }
 175
 176 =head2 get_bug_log
 177
 178      my $bug_log = get_bug_log($bug);
 179      my $bug_log = get_bug_log($bug,$msg_num);
 180
 181 Retuns a parsed set of the bug log; this is an array of hashes with
 182 the following
 183
 184  [{html => '',
 185    header => '',
 186    body    => '',
 187    attachments => [],
 188    msg_num     => 5,
 189   },
 190   {html => '',
 191    header => '',
 192    body    => '',
 193    attachments => [],
 194   },
 195  ]
 196
 197
 198 Currently $msg_num is completely ignored.
 199
 200 =cut
 201
 202 use Debbugs::Log qw();
 203 use Debbugs::MIME qw(parse);
 204
 205 sub get_bug_log{
 206      my $VERSION = __populate_version(pop);
 207      my ($self,$bug,$msg_num) = @_;
 208
 209      my $location = getbuglocation($bug,'log');
 210      my $bug_log = getbugcomponent($bug,'log',$location);
 211
 212      my $log_fh = IO::File->new($bug_log, 'r') or
 213           die "Unable to open bug log $bug_log for reading: $!";
 214
 215      my $log = Debbugs::Log->new($log_fh) or
 216           die "Debbugs::Log was unable to be initialized";
 217
 218      my %seen_msg_ids;
 219      my $current_msg=0;
 220      my $status = {};
 221      my @messages;
 222      while (my $record = $log->read_record()) {
 223           $current_msg++;
 224           #next if defined $msg_num and ($current_msg ne $msg_num);
 225           next unless $record->{type} eq 'incoming-recv';
 226           my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
 227           next if defined $msg_id and exists $seen_msg_ids{$msg_id};
 228           $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
 229           next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
 230           my $message = parse($record->{text});
 231           my ($header,$body) = map {join("\n",make_list($_))}
 232                @{$message}{qw(header body)};
 233           push @messages,{header => $header,
 234                           body   => $body,
 235                           attachments => [],
 236                           msg_num => $current_msg,
 237                          };
 238      }
 239      return \@messages;
 240 }
 241
 242
 243 =head1 VERSION COMPATIBILITY
 244
 245 The functionality provided by the SOAP interface will change over time.
 246
 247 To the greatest extent possible, we will attempt to provide backwards
 248 compatibility with previous versions; however, in order to have
 249 backwards compatibility, you need to specify the version with which
 250 you are compatible.
 251
 252 =cut
 253
 254 sub __populate_version{
 255      my ($request) = @_;
 256      return $request->{___debbugs_soap_version};
 257 }
 258
 259 sub __collapse_params{
 260      my @params = @_;
 261
 262      my %params;
 263      # Because some clients can't handle passing arrayrefs, we allow
 264      # options to be specified multiple times
 265      while (my ($key,$value) = splice @params,0,2) {
 266           push @{$params{$key}}, make_list($value);
 267      }
 268      # However, for singly specified options, we want to pull them
 269      # back out
 270      for my $key (keys %params) {
 271           if (@{$params{$key}} == 1) {
 272                ($params{$key}) = @{$params{$key}}
 273           }
 274      }
 275      return %params;
 276 }
 277
 278
 279 1;
 280
 281
 282 __END__
 283
 284
 285
 286
 287
 288