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
  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 delete {
  64         my ($self, $url) = @_;
  65
  66         $self->request(DELETE => $url);
  67 }
  68
  69 sub get {
  70         my ($self, $url) = @_;
  71
  72         JSON->new->utf8->decode( $self->request(GET => $url) );
  73 }
  74
  75 sub put {
  76         my ($self, $url, $json) = @_;
  77
  78         if ( ! defined $json->{_rev} ) {
  79                 my $old = eval { $self->get( $url )->{_rev} };
  80                 $rev->{$url} = $json->{_rev} = $old if defined $old;
  81         }
  82
  83         my $data = dclone $json;
  84         $data = unbless $data if blessed $data;
  85
  86         warn dump( $data );
  87
  88         $json = JSON->new->utf8->encode( $data );
  89
  90         warn $json;
  91
  92         do {
  93                 eval { $self->request(PUT => $url, $json) };
  94                 $rev->{$url} = $self->get( $url )->{_rev} if $@;
  95         } until ! $@;
  96 }
  97
  98 sub post {
  99         my ($self, $url, $json) = @_;
 100
 101         $self->request(POST => $url, $json);
 102 }
 103
 104 our $audit = __PACKAGE__->new;
 105
 106 sub audit {
 107         my $data = pop @_;
 108
 109         my $url = join(' ', @_);
 110         $url =~ s/\s+-\S+//g;   # remove command line options
 111         $url =~ s/\W+/-/g;
 112
 113         my ( $package, $file, $line, $sub ) = caller(1);
 114 #       ( $package, undef, $line ) = caller(0) if $package eq 'main';
 115
 116         my $time = time();
 117
 118         $data->{$_} = eval '$' . $_ foreach ( qw/time package line sub/ );
 119
 120         warn 'audit ', dump($data), "at $file +$line\n";
 121
 122         $time = int($time); # reduce granularity
 123         $audit->put( "pxelator/$time.$package.$url", $data );
 124
 125 }
 126
 127 1;