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