lib/PXElator/CouchDB.pm

package CouchDB;

# http://wiki.apache.org/couchdb/Getting_started_with_Perl

use strict;
use warnings;

use LWP::UserAgent;
use JSON;
use Data::Dump qw/dump/;
use Time::HiRes qw/time/;
use Data::Structure::Util qw(unbless);
use Scalar::Util qw/blessed/;
use Storable qw/dclone/;
use Carp qw/carp/;

sub new {
        my ($class, $host, $port, $options) = @_;

        my $ua = LWP::UserAgent->new;
        $ua->timeout(10);
        $ua->env_proxy;

        $host ||= 'localhost';
        $port ||= 5984;

        return bless {
                ua                       => $ua,
                host             => $host,
                port             => $port,
                base_uri => "http://$host:$port/",
        }, $class;
}

sub ua { shift->{ua} }
sub base { shift->{base_uri} }

sub request {
        my ($self, $method, $uri, $content) = @_;

        my $full_uri = $self->base . $uri;
        my $req;

        if (defined $content) {
                #Content-Type: application/json

                $req = HTTP::Request->new( $method, $full_uri, undef, $content );
                $req->header('Content-Type' => 'application/json');
        } else {
                $req = HTTP::Request->new( $method, $full_uri );
        }

        my $response = $self->ua->request($req);

        if ($response->is_success) {
                return $response->content;
        } else {
                die($response->status_line . ":" . $response->content);
        }
}

our $rev;

sub rev {
        my ($self,$url) = @_;
        my $rev = $rev->{$url};
        $rev  ||= eval { $self->get( $url )->{_rev} };
#       warn "# rev $url $rev";
        return $rev;
}

sub delete {
        my ($self, $url) = @_;

        $self->request(DELETE => $url . '?rev=' . $self->rev($url) );
}

sub get {
        my ($self, $url) = @_;

        JSON->new->utf8->decode( $self->request(GET => $url) );
}

sub put {
        my ($self, $url, $json) = @_;

        $json->{_rev} = $rev->{$url} if defined $rev->{$url};

        my $data = dclone $json;
        $data = unbless $data if blessed $data;

#       warn "# put ",dump( $data );

        $json = JSON->new->utf8->encode( $data );

        carp "# put ",$json;

        do {
                my $json = eval { $self->request(PUT => $url, $json) };
                if ( $@ ) {
                        $rev->{$url} = $self->rev( $url );
                        warn "refresh rev $url = ", $rev->{$url};
                } else {
                        $rev->{$url} = JSON->new->decode( $json )->{rev};
                }
        } until ! $@;
}

sub post {
        my ($self, $url, $json) = @_;

        $self->request(POST => $url, $json);
}

our $audit = __PACKAGE__->new;

sub audit {
        my $data = pop @_;

        my $url = join(' ', @_);
        $url =~ s/\s+-\S+//g;   # remove command line options
        $url =~ s/\W+/-/g;

        my $time = $data->{time} = time();

        my @caller_name = ( qw/package file line sub/ );
        my @caller = caller(0);
        $caller[3] =~ s{^.+::}{}; # stip package name from sub
        $data->{ $caller_name[$_] } = $caller[$_] foreach ( 0 .. $#caller_name );

        my $caller;
        my $depth = 0;
        while ( my @c = caller($depth) ) {
                push @$caller, [ @c ];
                $depth++;
        }

        $data->{caller} = $caller;

#       carp 'audit ', dump($data);

        $time = int($time); # reduce granularity for url
        my $package = $caller[0];
        $audit->put( "pxelator/$time.$package.$url", $data );

}

1;
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	use Carp qw/carp/;
16
17	sub new {
18	my ($class, $host, $port, $options) = @_;
19
20	my $ua = LWP::UserAgent->new;
21	$ua->timeout(10);
22	$ua->env_proxy;
23
24	$host \|\|= 'localhost';
25	$port \|\|= 5984;
26
27	return bless {
28	ua => $ua,
29	host => $host,
30	port => $port,
31	base_uri => "http://$host:$port/",
32	}, $class;
33	}
34
35	sub ua { shift->{ua} }
36	sub base { shift->{base_uri} }
37
38	sub request {
39	my ($self, $method, $uri, $content) = @_;
40
41	my $full_uri = $self->base . $uri;
42	my $req;
43
44	if (defined $content) {
45	#Content-Type: application/json
46
47	$req = HTTP::Request->new( $method, $full_uri, undef, $content );
48	$req->header('Content-Type' => 'application/json');
49	} else {
50	$req = HTTP::Request->new( $method, $full_uri );
51	}
52
53	my $response = $self->ua->request($req);
54
55	if ($response->is_success) {
56	return $response->content;
57	} else {
58	die($response->status_line . ":" . $response->content);
59	}
60	}
61
62	our $rev;
63
64	sub rev {
65	my ($self,$url) = @_;
66	my $rev = $rev->{$url};
67	$rev \|\|= eval { $self->get( $url )->{_rev} };
68	# warn "# rev $url $rev";
69	return $rev;
70	}
71
72	sub delete {
73	my ($self, $url) = @_;
74
75	$self->request(DELETE => $url . '?rev=' . $self->rev($url) );
76	}
77
78	sub get {
79	my ($self, $url) = @_;
80
81	JSON->new->utf8->decode( $self->request(GET => $url) );
82	}
83
84	sub put {
85	my ($self, $url, $json) = @_;
86
87	$json->{_rev} = $rev->{$url} if defined $rev->{$url};
88
89	my $data = dclone $json;
90	$data = unbless $data if blessed $data;
91
92	# warn "# put ",dump( $data );
93
94	$json = JSON->new->utf8->encode( $data );
95
96	carp "# put ",$json;
97
98	do {
99	my $json = eval { $self->request(PUT => $url, $json) };
100	if ( $@ ) {
101	$rev->{$url} = $self->rev( $url );
102	warn "refresh rev $url = ", $rev->{$url};
103	} else {
104	$rev->{$url} = JSON->new->decode( $json )->{rev};
105	}
106	} until ! $@;
107	}
108
109	sub post {
110	my ($self, $url, $json) = @_;
111
112	$self->request(POST => $url, $json);
113	}
114
115	our $audit = __PACKAGE__->new;
116
117	sub audit {
118	my $data = pop @_;
119
120	my $url = join(' ', @_);
121	$url =~ s/\s+-\S+//g; # remove command line options
122	$url =~ s/\W+/-/g;
123
124	my $time = $data->{time} = time();
125
126	my @caller_name = ( qw/package file line sub/ );
127	my @caller = caller(0);
128	$caller[3] =~ s{^.+::}{}; # stip package name from sub
129	$data->{ $caller_name[$_] } = $caller[$_] foreach ( 0 .. $#caller_name );
130
131	my $caller;
132	my $depth = 0;
133	while ( my @c = caller($depth) ) {
134	push @$caller, [ @c ];
135	$depth++;
136	}
137
138	$data->{caller} = $caller;
139
140	# carp 'audit ', dump($data);
141
142	$time = int($time); # reduce granularity for url
143	my $package = $caller[0];
144	$audit->put( "pxelator/$time.$package.$url", $data );
145
146	}
147
148	1;