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