git.rot13.org Git - ILL-Zotero-RT/blob - CouchDB.pm

   1 package CouchDB;
   2
   3 use strict;
   4 use warnings;
   5
   6 use LWP::UserAgent;
   7 use JSON;
   8 use Digest::MD5 qw(md5_hex);
   9 use Data::Dump qw(dump);
  10
  11 sub new {
  12   my ($class, $host, $port, $options) = @_;
  13
  14   my $ua = LWP::UserAgent->new;
  15   $ua->timeout(10);
  16   $ua->env_proxy;
  17
  18   if ( $ENV{DEBUG} ) {
  19         $ua->add_handler("request_send",  sub { shift->dump; return });
  20         $ua->add_handler("response_done", sub { shift->dump; return });
  21   }
  22
  23   return bless {
  24                 ua       => $ua,
  25                 host     => $host,
  26                 port     => $port,
  27                 base_uri => "http://$host:$port/",
  28                }, $class;
  29 }
  30
  31 sub ua { shift->{ua} }
  32 sub base { shift->{base_uri} }
  33
  34 sub request {
  35   my ($self, $method, $uri, $content) = @_;
  36
  37   my $full_uri = $self->base . $uri;
  38   my $req;
  39
  40   if (defined $content) {
  41     #Content-Type: application/json
  42
  43     $req = HTTP::Request->new( $method, $full_uri, undef, encode_json $content );
  44     $req->header('Content-Type' => 'application/json');
  45   } else {
  46     $req = HTTP::Request->new( $method, $full_uri );
  47   }
  48
  49   my $response = $self->ua->request($req);
  50
  51   if ($response->is_success) {
  52     return decode_json $response->content;
  53   } else {
  54     die($response->status_line . ":" . $response->content);
  55   }
  56 }
  57
  58 sub delete {
  59   my ($self, $url) = @_;
  60
  61   $self->request(DELETE => $url);
  62 }
  63
  64 sub get {
  65   my ($self, $url) = @_;
  66
  67   warn "## GET $url";
  68   $self->request(GET => $url);
  69 }
  70
  71 sub put {
  72   my ($self, $url, $json) = @_;
  73
  74   warn "## PUT $url";
  75   $self->request(PUT => $url, $json);
  76 }
  77
  78 sub post {
  79   my ($self, $url, $json) = @_;
  80
  81   $self->request(POST => $url, $json);
  82 }
  83
  84 sub update {
  85         my ($self, $url, $json) = @_;
  86
  87         warn "# update_doc $url";
  88
  89         my $json_md5 = md5_hex encode_json $json;
  90         $json->{x_sync}->{json_md5} = $json_md5;
  91
  92         if ( my $old = eval { $self->get( $url ) } ) {
  93                 warn "# old ", $old->{_rev}; #dump($old);
  94
  95                 if ( $json_md5 ne $old->{x_sync}->{json_md5} ) {
  96                         $json->{_rev} = $old->{_rev};
  97                         warn :"# update $url";
  98                         $self->put( $url => $json );
  99                 } else {
 100                         warn "# unchanged $url";
 101                 }
 102         } else {
 103                 warn "# insert $url ", dump($json);
 104                 $self->put( $url => $json );
 105         }
 106
 107 }
 108
 109 1;