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 modify {
  90         my ($self, $url, $json) = @_;
  91
  92         carp "# modify $url ", ref $json;
  93
  94         my $ret;
  95
  96         if ( my $old = eval { $self->get( $url ) } ) {
  97                 warn "# old ", $old->{_rev}, dump($old);
  98
  99                 if ( ref $json eq 'CODE' ) {
 100                         $json = $json->( clone $old );
 101                         warn "# json CODE ",dump($json);
 102                 } else {
 103                         warn "# overwrite old";
 104                         $json->{_rev} = $old->{_rev};
 105                 }
 106
 107                 my $json_md5 = md5_hex encode_json $json;
 108                 $json->{x_sync}->{json_md5} = $json_md5;
 109
 110                 warn "# json_md5 $json_md5 == $old->{x_sync}->{json_md5}\n";
 111                 if ( $json_md5 ne $old->{x_sync}->{json_md5} ) {
 112                         warn "# modify $url";
 113                         $ret = $self->put( $url => $json );
 114                 } else {
 115                         warn "# unchanged $url";
 116                         $ret->{rev} = $old->{_rev};
 117                         $ret->{id}  = $old->{_id};
 118                 }
 119         } else {
 120                 $json = $json->({}) if ref $json eq 'CODE';
 121                 warn "# insert $url ", dump($json);
 122                 $ret = $self->put( $url => $json );
 123         }
 124
 125         return $ret;
 126 }
 127
 128 1;