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 Data::Structure::Util qw(unbless);
  12 use Scalar::Util qw/blessed/;
  13 use Storable qw/dclone/;
  14 use Carp qw/carp/;
  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 rev {
  64         my ($self,$url) = @_;
  65         my $rev = $rev->{$url};
  66         $rev  ||= eval { $self->get( $url )->{_rev} };
  67 #       warn "# rev $url $rev";
  68         return $rev;
  69 }
  70
  71 sub delete {
  72         my ($self, $url) = @_;
  73
  74         $self->request(DELETE => $url . '?rev=' . $self->rev($url) );
  75 }
  76
  77 sub get {
  78         my ($self, $url) = @_;
  79
  80         JSON->new->utf8->decode( $self->request(GET => $url) );
  81 }
  82
  83 sub put {
  84         my ($self, $url, $json) = @_;
  85
  86         $json->{_rev} = $rev->{$url} if defined $rev->{$url};
  87
  88         my $data = dclone $json;
  89         $data = unbless $data if blessed $data;
  90
  91 #       warn "# put ",dump( $data );
  92
  93         $json = JSON->new->utf8->encode( $data );
  94
  95         carp "# put ",$json;
  96
  97         do {
  98                 my $json = eval { $self->request(PUT => $url, $json) };
  99                 if ( $@ ) {
 100                         $rev->{$url} = $self->rev( $url );
 101                         warn "refresh rev $url = ", $rev->{$url};
 102                 } else {
 103                         $rev->{$url} = JSON->new->decode( $json )->{rev};
 104                 }
 105         } until ! $@;
 106 }
 107
 108 sub post {
 109         my ($self, $url, $json) = @_;
 110
 111         $self->request(POST => $url, $json);
 112 }
 113
 114 our $audit = __PACKAGE__->new;
 115
 116 sub _store_audit {
 117         my ( $id, $data ) = @_;
 118         $audit->put( "pxelator/$id", $data );
 119 }
 120
 121 1;