2b3357fe50061ecc97bdea385270effbc0f423c3
[pxelator] / lib / PXElator / CouchDB.pm
1 package CouchDB;
2
3 # http://wiki.apache.org/couchdb/Getting_started_with_Perl
4
5 use strict;
6 use warnings;
7
8 use LWP::UserAgent;
9 use JSON;
10 use Data::Dump qw/dump/;
11 use Time::HiRes qw/time/;
12 use Data::Structure::Util qw(unbless);
13 use Scalar::Util qw/blessed/;
14 use Storable qw/dclone/;
15
16 sub new {
17         my ($class, $host, $port, $options) = @_;
18
19         my $ua = LWP::UserAgent->new;
20         $ua->timeout(10);
21         $ua->env_proxy;
22
23         $host ||= 'localhost';
24         $port ||= 5984;
25
26         return bless {
27                 ua                       => $ua,
28                 host             => $host,
29                 port             => $port,
30                 base_uri => "http://$host:$port/",
31         }, $class;
32 }
33
34 sub ua { shift->{ua} }
35 sub base { shift->{base_uri} }
36
37 sub request {
38         my ($self, $method, $uri, $content) = @_;
39
40         my $full_uri = $self->base . $uri;
41         my $req;
42
43         if (defined $content) {
44                 #Content-Type: application/json
45
46                 $req = HTTP::Request->new( $method, $full_uri, undef, $content );
47                 $req->header('Content-Type' => 'application/json');
48         } else {
49                 $req = HTTP::Request->new( $method, $full_uri );
50         }
51
52         my $response = $self->ua->request($req);
53
54         if ($response->is_success) {
55                 return $response->content;
56         } else {
57                 die($response->status_line . ":" . $response->content);
58         }
59 }
60
61 our $rev;
62
63 sub delete {
64         my ($self, $url) = @_;
65
66         $self->request(DELETE => $url);
67 }
68
69 sub get {
70         my ($self, $url) = @_;
71
72         JSON->new->utf8->decode( $self->request(GET => $url) );
73 }
74
75 sub put {
76         my ($self, $url, $json) = @_;
77         warn "put $url ",dump($json);
78
79         if ( ! defined $json->{_rev} ) {
80                 my $old = eval { $self->get( $url )->{_rev} };
81                 $rev->{$url} = $json->{_rev} = $old if defined $old;
82         }
83
84         $json = unbless dclone $json if blessed $json;
85
86         $json = JSON->new->utf8->encode( $json ) if $json;
87
88         $self->request(PUT => $url, $json);
89 }
90
91 sub post {
92         my ($self, $url, $json) = @_;
93
94         $self->request(POST => $url, $json);
95 }
96
97 our $audit = __PACKAGE__->new;
98
99 sub audit {
100         my $data = pop @_;
101
102         my $url = join(' ', @_);
103         $url =~ s/-\S+//g;
104         $url =~ s/\W+/-/g;
105
106         my ( $package, undef, $line, $sub ) = caller(1);
107         ( $package, undef, $line ) = caller(0) if $package eq 'main';
108
109         $data->{x_meta} = {
110                 'ident' => [ @_ ],
111                 'time' => time(),
112                 'package' => $package,
113                 'line' => $line,
114                 'sub' => $sub,
115         };
116
117         $audit->put( "pxelator/$package.$url", $data );
118 }
119
120 1;