--- trunk/lib/Frey/CouchAPI.pm 2009/04/22 23:38:10 1047 +++ trunk/lib/Frey/CouchAPI.pm 2009/04/23 20:12:45 1052 @@ -1,11 +1,33 @@ package Frey::CouchAPI; +=head1 DESCRIPTION + +This is REST wrapper using following L implement Apache's CouchDB API + + +L + +L + + +=head1 Supported HTTP API + +=cut + +use warnings; +use strict; + use JSON; use Data::Dump qw/dump/; use URI::Escape; use File::Path qw(make_path remove_tree); use Storable; +our $VERSION = '0.1'; +$VERSION .= ' on Frey ' . $Frey::VERSION; + +our $debug = $Frey::debug || 0; + sub rewrite_urls { my ( $self, $tx ) = @_; if ( $tx->req->url->path =~ m{/_utils/} ) { @@ -20,43 +42,90 @@ } } -my $path = '/data/webpac2/var/row'; +our $config = { + path => '/data/webpac2/var/row', +}; + +my $p = $config->{path}; my @all_dbs = map { - s{^\Q$path\E/*}{}; + s{^\Q$p\E/*}{}; $_; -} glob "$path/*/*"; +} glob "$p/*/*"; my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+'; our $json = {}; -our $stauts = 500; +our $status; sub ok { $json = { ok => JSON::true }; $status = 200; + warn "ok\n"; } + sub dispatch { my ($self,$tx) = @_; + $status = 500; # Internal Error + my $url = $tx->req->url->to_string; $url = uri_unescape( $url ); my $method = $tx->req->method; - - warn "INFO: using Apache CouchDB emulation API\n"; - + if ( $url eq '/' ) { $json = { couchdb => "Welcome", - version => "0-Frey", - } + version => "CouchAPI $VERSION", + }; + $status = 200; } elsif ( $url eq '/_all_dbs' ) { $json = [ @all_dbs ]; $status = 200; + } elsif ( $url =~ m{^/_config/?(.+)} ) { + + $json = { CouchAPI => $config }; + + if ( $method eq 'PUT' ) { + + my $part = $1; + warn "## part $part"; + + $part =~ s!^!->{'!; + $part =~ s!/!'}->{'!; + $part =~ s/$/'}/; + + my $data = $tx->req->content->file->slurp; + $data = JSON->new->allow_nonref->decode( $data ); + warn "## data ",dump( $data ); + # poor man's transaction :-) + my $code = "\$json$part = \$data; \$config$part = \$data;"; + eval $code; + if ( $@ ) { + warn "ERROR: $code -> $@"; + $status = 500; + } else { + $status = 200; + } + +warn "json ",dump( $json ), " config ", dump( $config ); + + } elsif ( $method eq 'GET' ) { + $status = 200; + } else { + $status = 501; + } + } elsif ( $url =~ m{($regex_dbs)/$} ) { +=head2 Database + +L except compaction + +=cut + my $database = $1; - my $dir = "$path/$database"; + my $dir = "$config->{path}/$database"; if ( $method eq 'GET' ) { $json = database_get( $database ); @@ -64,42 +133,92 @@ if ( ! -e $dir ) { $status = 404; } else { - remove_tree($dir) && ok || { $status = 501 }; + remove_tree($dir) && ok || { $status = 500 }; } } elsif ( $method eq 'PUT' ) { if ( ! -e $dir ) { - make_path($dir) && ok && warn "created $dir" || { $status = 501 }; + make_path($dir) && ok && warn "created $dir" || { $status = 500 }; } else { $status = 412; } } - } elsif ( $url =~ m{($regex_dbs)/(.+)$} ) { - my ($database,$id) = ($1,$2); - + } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) { + my ($database,$id,$args) = ($1,$2,$3); + +=head2 Document + +L + +=cut + + my $arg; + if ( $args ) { + foreach my $a ( split(/[&;]/,$args) ) { + my ($n,$v) = split(/=/,$a); + $v =~ s{(["'])(.+)\1}{$2}; + $arg->{$n} = $v; + } + } + + my $path = $config->{path}; + warn "ERROR: path $path doesn't exist\n" unless -e $path; + my $p = "$path/$database/$id"; - warn "## database: $database id: $id -> $p "; + warn "## database: $database id: $id -> $p ", dump( $arg ),"\n"; + + + if ( $id =~ m{_all_docs(\w+)?$} ) { - if ( $id eq '_all_docs' ) { + my $by = $1; + my $offset = 0; + my $startkey = delete $arg->{startkey}; + my $endkey = delete $arg->{endkey}; + my $limit = delete $arg->{limit}; + my $total_rows = 0; - my @docs = map { + my @docs = grep { length $_ } map { + return '' if defined $limit && $total_rows == $limit; + s{^$path/$database/}{}; - $_; + return '' if defined $endkey && $_ gt $endkey; + + if ( $startkey ) { + if ( $_ ge $startkey ) { + $total_rows++; + $_; + } else { + $offset++; + return ''; + } + } else { + $total_rows++; + $_; + } + } glob( "$path/$database/*" ); - warn "## docs ", dump( @docs ); + warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug; $json = { - total_rows => $#docs + 1, - offset => 0, + total_rows => $total_rows, + offset => $offset, rows => [], }; + my $rows; + my @ids; + foreach my $id ( @docs ) { - warn "++ $id\n"; + warn "++ $id\n" if $debug; my $p = "$path/$database/$id"; - my $data = Storable::retrieve( $p ); - push @{ $json->{rows} }, { + my $data = eval { Storable::retrieve( $p ) }; + if ( $@ ) { + warn "ERROR: $p | $@\n"; + next; + } + push @ids, $id; + $rows->{$id} = { id => $id, key => $id, value => { @@ -108,26 +227,51 @@ }; } + my $descending = delete $arg->{descending}; + my @sorted = sort @ids; + + warn "creating rows in ", $descending ? "descending" : "", " order\n"; + + foreach my $id ( $descending ? reverse @sorted : @sorted ) { + warn ">> $id ", $descending ? 'desc' : 'asc', "\n" if $debug; + push @{ $json->{rows} }, $rows->{$id}; + } + } elsif ( $method eq 'PUT' ) { - warn "## ",dump( $tx->req ); + warn "## ",dump( $tx->req ) if $debug; my $data = $tx->req->content->file->slurp; Storable::store( from_json($data), $p ); warn "store $p ", -s $p, " bytes: $data\n"; + $status = 201; # Created + } elsif ( $method eq 'GET' ) { - warn "retrive $p ", -s $p, " bytes\n"; - $json = Storable::retrieve( $p ); + if ( ! -e $p ) { + $status = 404; + } else { + warn "retrive $p ", -s $p, " bytes\n"; + $json = Storable::retrieve( $p ); + } + } elsif ( $method eq 'DELETE' ) { + if ( -e $p ) { + unlink $p || { $status = 500 }; + } else { + $status = 404; + } } else { $status = 501; } + warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg; + } - if ( $status >= 400 && $status < 500 && ! defined $json) { - $json = { error => 'not_found', reason => 'Missing' }; - warn "fake $status"; + $json = { error => 'not_found', reason => 'Missing' } if $status == 404; + + if ( $method =~ m{(DELETE|PUT)} ) { + $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs ); } $tx->res->code( $status ); @@ -135,12 +279,16 @@ my $body = to_json $json; $tx->res->body( $body ); warn "CouchDB API: $method $url $status $body\n"; + + warn "## headers ", $tx->res->headers->to_string; + return $tx; } sub database_get { my ($db_name) = @_; + my $path = $config->{path}; warn "# collecting docs from $path/$db_name/*\n"; my @docs = glob "$path/$db_name/*"; my $json = { @@ -155,9 +303,15 @@ }; warn "## calculating disk_size\n"; - $json->{disk_size} += -s "$path/$1/$_" foreach $docs; + $json->{disk_size} += -s $_ foreach @docs; $status = 200; return $json; } 1; +__END__ + +=head1 SEE ALSO + +L +