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
  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 _store_audit {
 118         my ( $id, $data ) = @_;
 119         $audit->put( "pxelator/$id", $data );
 120 }
 121
 122 1;