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