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