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 use Encode;
  11 use Carp;
  12 use Clone qw(clone);
  13
  14 sub new {
  15   my ($class, $host, $port, $options) = @_;
  16
  17   my $ua = LWP::UserAgent->new;
  18   $ua->timeout(10);
  19   $ua->env_proxy;
  20
  21   if ( $ENV{DEBUG} ) {
  22         $ua->add_handler("request_send",  sub { shift->dump; return });
  23         $ua->add_handler("response_done", sub { shift->dump; return });
  24   }
  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, $content_type) = @_;
  39   $content_type ||= 'application/json';
  40
  41   my $full_uri = $self->base . $uri;
  42   my $req;
  43
  44   warn "# request $method $full_uri ", $content ? length($content) : '-' , " $content_type\n";
  45
  46   if (defined $content) {
  47     $req = HTTP::Request->new( $method, $full_uri, undef );
  48     $req->header( 'Content-Type' => $content_type );
  49     my $bytes = ref($content) ? encode_json($content) : $content;
  50     $req->content( $bytes ); # convert to bytes
  51     warn "### ",dump($bytes);
  52   } else {
  53     $req = HTTP::Request->new( $method, $full_uri );
  54   }
  55
  56   my $response = $self->ua->request($req);
  57
  58   if ($response->is_success) {
  59     return decode_json $response->content;
  60   } else {
  61     die($response->status_line . ":" . $response->content);
  62   }
  63 }
  64
  65 sub delete {
  66   my ($self, $url) = @_;
  67
  68   $self->request(DELETE => $url);
  69 }
  70
  71 sub get {
  72   my ($self, $url) = @_;
  73
  74   $self->request(GET => $url);
  75 }
  76
  77 sub put {
  78   my ($self, $url, $json) = @_;
  79
  80   $self->request(PUT => $url, $json);
  81 }
  82
  83 sub post {
  84   my ($self, $url, $json) = @_;
  85
  86   $self->request(POST => $url, $json);
  87 }
  88
  89 sub x_sync {
  90         my ($json,$old) = @_;
  91         $json->{$_} = $old->{$_} foreach keys %{ $old->{x_meta} }; # special persistent x_meta fields
  92         my $json_md5 = md5_hex encode_json $json;
  93         $json->{x_sync}->{json_md5} = $json_md5;
  94         my $o =  $old->{x_sync}->{json_md5};
  95         my $n = $json->{x_sync}->{json_md5};
  96         warn "## x_sync $o ", $o eq $n ? '==' : '!=', " $n\n";
  97         return $json;
  98 }
  99
 100
 101 sub modify {
 102         my ($self, $url, $json) = @_;
 103
 104         carp "# modify $url ", ref $json;
 105
 106         my $ret;
 107
 108         if ( my $old = eval { $self->get( $url ) } ) {
 109                 warn "# old ", $old->{_rev}, dump($old);
 110
 111                 if ( ref $json eq 'CODE' ) {
 112                         $json = $json->( clone $old );
 113                         warn "# json CODE ",dump($json);
 114                 } else {
 115                         warn "# overwrite old";
 116                         $json->{_rev} = $old->{_rev};
 117                 }
 118
 119                 $json = x_sync($json, $old);
 120
 121                 if ( $json->{x_sync}->{json_md5} ne $old->{x_sync}->{json_md5} ) {
 122                         warn "# modify $url";
 123                         $ret = $self->put( $url => $json );
 124                 } else {
 125                         warn "# unchanged $url";
 126                         $ret->{rev} = $old->{_rev};
 127                         $ret->{id}  = $old->{_id};
 128                 }
 129         } else {
 130                 $json = $json->({}) if ref $json eq 'CODE';
 131
 132                 $json = x_sync($json);
 133
 134                 warn "# insert $url ", dump($json);
 135                 $ret = $self->put( $url => $json );
 136         }
 137
 138         return $ret;
 139 }
 140
 141 1;