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