File Coverage

blib/lib/AnyEvent/WebService/Tracks.pm
Criterion Covered Total %
statement 25 27 92.5
branch n/a
condition n/a
subroutine 9 9 100.0
pod n/a
total 34 36 94.4


line stmt bran cond sub pod time code
1             package AnyEvent::WebService::Tracks;
2              
3 10     10   209583 use strict;
  10         26  
  10         407  
4 10     10   54 use warnings;
  10         19  
  10         356  
5              
6 10     10   11055 use AnyEvent::HTTP qw(http_request);
  10         429401  
  10         1144  
7 10     10   115 use Carp qw(croak);
  10         17  
  10         452  
8 10     10   23490 use DateTime;
  10         1924573  
  10         436  
9 10     10   10989 use DateTime::Format::ISO8601;
  10         524258  
  10         1075  
10 10     10   18404 use MIME::Base64 qw(encode_base64);
  10         10764  
  10         874  
11 10     10   184494 use URI;
  10         71842  
  10         410  
12 10     10   16846 use XML::Parser;
  0            
  0            
13             use XML::Writer;
14              
15             use AnyEvent::WebService::Tracks::Context;
16             use AnyEvent::WebService::Tracks::Project;
17             use AnyEvent::WebService::Tracks::Todo;
18              
19             our $VERSION = '0.02';
20              
21             sub new {
22             my ( $class, %params ) = @_;
23              
24             return bless {
25             url => URI->new($params{url}),
26             username => $params{username},
27             password => $params{password},
28             }, $class;
29             }
30              
31             sub parse_datetime {
32             my ( $self, $str ) = @_;
33              
34             return DateTime::Format::ISO8601->parse_datetime($str);
35             }
36              
37             sub format_datetime {
38             my ( $self, $datetime ) = @_;
39              
40             my @fields = qw/year month day hour minute second/;
41             my %attrs = map { $_ => $datetime->$_() } @fields;
42             my $offset = DateTime::TimeZone->offset_as_string($datetime->offset);
43              
44             return sprintf '%04d-%02d-%02dT%02d:%02d:%02d%s', @attrs{@fields}, $offset;
45             }
46              
47             sub handle_error {
48             my ( $self, $body, $headers, $cb ) = @_;
49              
50             my $message;
51              
52             if($body) {
53             # context creation serves errors in XML, but project creation in plain text,
54             # even though the Content-Type is application/xml...
55             if($body =~ /^\s*<\?xml/) {
56             my $error = $self->parse_single(undef, $body);
57             $message = $error->{'error'};
58             } else {
59             $message = $body;
60             }
61             } else {
62             $message = $headers->{'status'};
63             }
64              
65             $cb->(undef, $message);
66             }
67              
68             sub generate_xml {
69             my ( $self, $root, $attrs ) = @_;
70              
71             my $xml = '';
72             my $w = XML::Writer->new(OUTPUT => \$xml);
73             my @keys = sort keys %$attrs;
74              
75             $w->startTag($root);
76             foreach my $k (@keys) {
77             my $v = $attrs->{$k};
78             my @xml_attrs;
79              
80             push @xml_attrs, (nil => 'true') unless defined $v;
81             if(ref($v) eq 'DateTime') {
82             push @xml_attrs, (type => 'datetime');
83             $v = $self->format_datetime($v);
84             }
85              
86             my $nk = $k;
87             $nk =~ tr/_/-/;
88              
89             $w->startTag($nk, @xml_attrs);
90             $w->characters($v) if defined $v;
91             $w->endTag($nk);
92             }
93             $w->endTag($root);
94             $w->end;
95              
96             return $xml;
97             }
98              
99             sub status_successful {
100             my ( $self, $status ) = @_;
101              
102             return ($status >= 200 && $status < 300);
103             }
104              
105             sub do_request {
106             my ( $self, $http_method, $uri, $params, $method, $cb ) = @_;
107              
108             my ( $username, $password ) = @{$self}{qw/username password/};
109              
110             my $auth_token = encode_base64(join(':', $username, $password), '');
111             $params->{'headers'} = {
112             Authorization => "Basic $auth_token",
113             Accept => 'application/xml',
114             Referer => undef,
115             };
116             if($params->{'body'}) {
117             $params->{'headers'}{'Content-Type'} = 'text/xml';
118             }
119              
120             my $handle_result = sub {
121             my ( $data, $headers ) = @_;
122              
123             if($self->status_successful($headers->{'Status'})) {
124             $cb->($self->$method($data, $headers));
125             } else {
126             $self->handle_error($data, $headers, $cb);
127             }
128             };
129              
130             unless(ref($uri) eq 'URI') {
131             if(ref($uri) eq 'ARRAY') {
132             my $copy = $self->{url}->clone;
133             $copy->path_segments($copy->path_segments, @$uri);
134             $uri = $copy;
135             }
136             }
137              
138             http_request $http_method, $uri, %$params, $handle_result;
139             }
140              
141             sub do_get {
142             my ( $self, $uri, $method, $cb ) = @_;
143              
144             $self->do_request(GET => $uri, {}, $method, $cb);
145             }
146              
147             sub do_delete {
148             my ( $self, $uri, $method, $cb ) = @_;
149              
150             $self->do_request(DELETE => $uri, {}, $method, $cb);
151             }
152              
153             sub do_post {
154             my ( $self, $uri, $body, $method, $cb ) = @_;
155              
156             $self->do_request(POST => $uri, { body => $body }, $method, $cb);
157             }
158              
159             sub do_put {
160             my ( $self, $uri, $body, $method, $cb ) = @_;
161              
162             $self->do_request(PUT => $uri, { body => $body }, $method, $cb);
163             }
164              
165             sub parse_entities {
166             my ( $self, $xml, $type, $target_depth ) = @_;
167              
168             my @entities;
169             my $current_entity;
170             my $current_tag;
171             my $current_attrs;
172             my $depth = 0;
173              
174             my $parser = XML::Parser->new(
175             Handlers => {
176             Start => sub {
177             my ( undef, $tag, %attrs ) = @_;
178              
179             if($depth == $target_depth) {
180             $current_entity = {};
181             } elsif($depth > $target_depth) {
182             $current_tag = $tag;
183             $current_attrs = \%attrs;
184              
185             $current_tag =~ tr/-/_/;
186              
187             my $nil = $attrs{'nil'};
188             $nil = defined($nil) && $nil eq 'true';
189            
190             if($nil) {
191             $current_entity->{$current_tag} = undef;
192             } else {
193             $current_entity->{$current_tag} = '';
194             }
195             }
196              
197             $depth++;
198             },
199             End => sub {
200             my ( undef, $tag ) = @_;
201              
202             $depth--;
203              
204             if($depth == $target_depth) {
205             if(defined $type) {
206             push @entities, $type->new(parent => $self,
207             %$current_entity);
208             } else {
209             push @entities, $current_entity;
210             }
211              
212             undef $current_entity;
213             undef $current_tag;
214             undef $current_attrs;
215             } elsif($depth > $target_depth) {
216             my $type = $current_attrs->{'type'};
217             $type = '' unless defined $type;
218              
219             if($type eq 'datetime') {
220             my $value = $current_entity->{$current_tag};
221              
222             if(defined $value) {
223             $current_entity->{$current_tag} =
224             $self->parse_datetime($value);
225             }
226             }
227             undef $current_tag;
228             undef $current_attrs;
229             }
230             },
231             Char => sub {
232             my ( undef, $chars ) = @_;
233              
234             if(defined $current_tag) {
235             $current_entity->{$current_tag} .= $chars;
236             }
237             },
238             },
239             );
240              
241             $parser->parse($xml);
242              
243             return \@entities;
244             }
245              
246             sub parse_single {
247             my ( $self, $type, $xml ) = @_;
248              
249             return $self->parse_entities($xml, $type, 0)->[0];
250             }
251              
252             sub parse_multiple {
253             my ( $self, $type, $xml ) = @_;
254              
255             return $self->parse_entities($xml, $type, 1);
256             }
257              
258             sub fetch_multiple {
259             my ( $self, $path, $type, $cb ) = @_;
260              
261             my $uri = $self->{'url'}->clone;
262             my @segments = split /\//, $path . '.xml';
263             $uri->path_segments($uri->path_segments, @segments);
264              
265             $self->do_get($uri, sub {
266             my ( undef, $data ) = @_;
267              
268             return $self->parse_multiple($type, $data);
269             }, $cb);
270             }
271              
272             sub fetch_from_location {
273             my ( $self, $url, $type, $cb ) = @_;
274              
275             $self->do_get($url, sub {
276             my ( undef, $data ) = @_;
277              
278             return $self->parse_single($type, $data);
279             }, $cb);
280             }
281              
282             sub fetch_single {
283             my ( $self, $path, $id, $type, $cb ) = @_;
284              
285             my $uri = $self->{'url'}->clone;
286             $uri->path_segments($uri->path_segments, $path, "$id.xml");
287              
288             $self->fetch_from_location($uri, $type, $cb);
289             }
290              
291             sub create {
292             my ( $self, $path, $type, $root, $attrs, $cb ) = @_;
293              
294             my $uri = $self->{'url'}->clone;
295             $uri->path_segments($uri->path_segments, $path . '.xml');
296              
297             my $xml = $self->generate_xml($root, $attrs);
298              
299             $self->do_post($uri, $xml, sub {
300             # pass the data and headers along to the following callback
301             return @_[1, 2];
302             }, sub {
303             my ( $data, $headers ) = @_;
304              
305             # handle errors during the last phase
306             unless(defined $data) {
307             $cb->($data, $headers);
308             return;
309             }
310              
311             if($self->status_successful($headers->{'Status'})) {
312             my $location = $headers->{'location'};
313              
314             $self->fetch_from_location($location, $type, $cb);
315             } else {
316             $self->handle_error($data, $headers, $cb);
317             }
318             });
319             }
320              
321             sub projects {
322             my ( $self, $cb ) = @_;
323              
324             $self->fetch_multiple('projects', 'AnyEvent::WebService::Tracks::Project', $cb);
325             }
326              
327             sub contexts {
328             my ( $self, $cb ) = @_;
329              
330             $self->fetch_multiple('contexts', 'AnyEvent::WebService::Tracks::Context', $cb);
331             }
332              
333             sub todos {
334             my ( $self, $cb ) = @_;
335              
336             $self->fetch_multiple('todos', 'AnyEvent::WebService::Tracks::Todo', $cb);
337             }
338              
339             sub create_context {
340             my $self = shift;
341             my $cb = pop;
342             my %params;
343              
344             if(@_ == 1) {
345             ( $params{'name'} ) = @_;
346             } else {
347             %params = @_;
348             }
349             if(exists $params{'hide'}) {
350             $params{'hide'} = $params{'hide'} ? 'true' : 'false';
351             }
352              
353             $self->create('contexts', 'AnyEvent::WebService::Tracks::Context',
354             context => \%params, $cb);
355             }
356              
357             sub create_project {
358             my $self = shift;
359             my $cb = pop;
360             my %params;
361              
362             if(@_ == 1) {
363             ( $params{'name'} ) = @_;
364             } else {
365             %params = @_;
366             }
367             if(exists $params{'default_context'}) {
368             my $ctx = delete $params{'default_context'};
369             if(defined $ctx) {
370             unless(ref($ctx) eq 'AnyEvent::WebService::Tracks::Context') {
371             croak "Parameter 'default_context' is not an AnyEvent::WebService::Tracks::Context";
372             }
373             $params{'default_context_id'} = $ctx->id;
374             }
375             }
376              
377             $self->create('projects', 'AnyEvent::WebService::Tracks::Project',
378             project => \%params, $cb);
379             }
380              
381             sub create_todo {
382             my $self = shift;
383             my $cb = pop;
384             my %params;
385              
386             if(@_ == 2) {
387             if(ref($_[1]) eq 'AnyEvent::WebService::Tracks::Project') {
388             ( @params{qw/description project/} ) = @_;
389             } else {
390             ( @params{qw/description context/} ) = @_;
391             }
392             } else {
393             %params = @_;
394             }
395             if(my $context = delete $params{'context'}) {
396             unless(ref($context) eq 'AnyEvent::WebService::Tracks::Context') {
397             croak "Parameter 'context' is not an AnyEvent::WebService::Tracks::Context";
398             }
399             $params{'context_id'} = $context->id;
400             }
401             if(my $project = delete $params{'project'}) {
402             unless(ref($project) eq 'AnyEvent::WebService::Tracks::Project') {
403             croak "Parameter 'project' is not an AnyEvent::WebService::Tracks::Project";
404             }
405             $params{'project_id'} = $project->id;
406             # naughty...violation of privacy
407             if(! exists($params{'context_id'}) && defined($project->{'default_context_id'})) {
408             $params{'context_id'} = $project->{'default_context_id'};
409             }
410             }
411             unless(exists $params{'context_id'} || exists $params{'project_id'}) {
412             croak "Required parameters 'context' and 'project' not found; you must specify at least one of them";
413             }
414              
415             if(my $project = delete $params{'project'}) {
416             unless(ref($project) eq 'AnyEvent::WebService::Tracks::Project') {
417             croak "Parameter 'project' is not an AnyEvent::WebService::Tracks::Project";
418             }
419             $params{'project_id'} = $project->id;
420             }
421              
422             $self->create('todos', 'AnyEvent::WebService::Tracks::Todo',
423             todo => \%params, $cb);
424             }
425              
426             1;
427              
428             __END__