--- trunk/lib/Frey/CouchAPI.pm 2009/04/23 20:24:48 1053 +++ trunk/lib/Frey/CouchAPI.pm 2009/04/28 16:38:18 1071 @@ -4,6 +4,8 @@ This is REST wrapper using following L implement Apache's CouchDB API +You can access it using normal C URI, just like on real CouchDB and +it will bring up partially functional Futon interface against this module. L @@ -23,7 +25,7 @@ use File::Path qw(make_path remove_tree); use Storable; -our $VERSION = '0.2'; +our $VERSION = '0.3'; $VERSION .= " (Frey $Frey::VERSION)" if $Frey::VERSION; our $debug = $Frey::debug || 0; @@ -43,15 +45,12 @@ } our $config = { - path => '/data/webpac2/var/row', + database => { + path => '/data/webpac2/var/row', + name_glob => '/*/*', + } }; -my $p = $config->{path}; -my @all_dbs = map { - s{^\Q$p\E/*}{}; - $_; -} glob "$p/*/*"; - my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+'; our $json = {}; @@ -60,9 +59,18 @@ sub ok { $json = { ok => JSON::true }; $status = 200; - warn "ok\n"; + warn "ok from ",join(' ',caller),$/; } +sub file_rev { (stat($_[0]))[9] } # mtime + +sub data_from_tx { + my $tx = shift; + my $data = $tx->req->content->file->slurp; + $data = JSON->new->allow_nonref->decode( $data ); + warn "## data ",dump( $data ); + return $data; +} sub dispatch { my ($self,$tx) = @_; @@ -72,6 +80,7 @@ my $url = $tx->req->url->to_string; $url = uri_unescape( $url ); my $method = $tx->req->method; + my $path = $config->{database}->{path}; if ( $url eq '/' ) { $json = { @@ -80,26 +89,27 @@ }; $status = 200; } elsif ( $url eq '/_all_dbs' ) { - $json = [ @all_dbs ]; + $json = [ + map { + s{^\Q$path\E/*}{}; + $_; + } glob $path . $config->{database}->{name_glob} + ]; $status = 200; } elsif ( $url =~ m{^/_config/?(.+)} ) { - $json = { CouchAPI => $config }; + $json = $config; if ( $method eq 'PUT' ) { my $part = $1; - warn "## part $part"; + my $data = data_from_tx( $tx ); + warn "## part $part = $data\n"; - $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;"; + my $code = "\$config->{'$part'} = \$data;"; eval $code; if ( $@ ) { warn "ERROR: $code -> $@"; @@ -108,7 +118,7 @@ $status = 200; } -warn "json ",dump( $json ), " config ", dump( $config ); + warn "# config after $code is ",dump( $config ),$/; } elsif ( $method eq 'GET' ) { $status = 200; @@ -116,16 +126,21 @@ $status = 501; } - } elsif ( $url =~ m{($regex_dbs)/$} ) { - =head2 Database L except compaction =cut + } elsif ( + $url =~ m{($regex_dbs)/$} + # DELETE doesn't have trailing slash + || $method eq 'DELETE' && $url =~ m{($regex_dbs)$} + ) { + my $database = $1; - my $dir = "$config->{path}/$database"; + + my $dir = "$path/$database"; if ( $method eq 'GET' ) { $json = database_get( $database ); @@ -133,16 +148,29 @@ if ( ! -e $dir ) { $status = 404; } else { - remove_tree($dir) && ok || { $status = 500 }; + remove_tree($dir); + if ( ! -d $dir ) { + ok; + } else { + $status = 500; + } } } elsif ( $method eq 'PUT' ) { - if ( ! -e $dir ) { - make_path($dir) && ok && warn "created $dir" || { $status = 500 }; - } else { + if ( -e $dir ) { $status = 412; + } else { + make_path($dir); + if ( -e $path ) { + ok; + $status = 201; + } else { + $status = 500; + } } } + warn "## database $database $status ",dump( $json ); + } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) { my ($database,$id,$args) = ($1,$2,$3); @@ -161,43 +189,54 @@ } } - 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 ", dump( $arg ),"\n"; - if ( $id =~ m{_all_docs(\w+)?$} ) { + if ( $id =~ m{_all_docs(\w*)$} ) { my $by = $1; my $offset = 0; my $startkey = delete $arg->{startkey}; + $startkey ||= delete $arg->{startkey_docid}; # XXX key == id my $endkey = delete $arg->{endkey}; my $limit = delete $arg->{limit}; + my $skip = delete $arg->{skip}; my $total_rows = 0; + my $collected_rows = 0; my @docs = grep { length $_ } map { - return '' if defined $limit && $total_rows == $limit; + + $total_rows++; + + if ( $limit > 0 && $collected_rows == $limit ) { + ''; + } else { - s{^$path/$database/}{}; - return '' if defined $endkey && $_ gt $endkey; + s{^$path/$database/}{}; - if ( $startkey ) { - if ( $_ ge $startkey ) { - $total_rows++; - $_; + if ( defined $endkey && $_ gt $endkey ) { + ''; + } elsif ( $startkey ) { + if ( $_ ge $startkey ) { + $collected_rows++; + $_; + } else { + $offset++; + ''; + } } else { - $offset++; - return ''; + $collected_rows++; + $_; } - } else { - $total_rows++; - $_; } } glob( "$path/$database/*" ); + $offset += $skip if $skip; + warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug; $json = { @@ -222,7 +261,7 @@ id => $id, key => $id, value => { - rev => (stat($p))[9], # mtime + rev => file_rev $p, } }; } @@ -237,34 +276,65 @@ push @{ $json->{rows} }, $rows->{$id}; } + $status = 200; + } elsif ( $method eq 'PUT' ) { warn "## ",dump( $tx->req ) if $debug; my $data = $tx->req->content->file->slurp; + my $db_path = "$path/$database"; + make_path $db_path unless -e $db_path; + Storable::store( from_json($data), $p ); - warn "store $p ", -s $p, " bytes: $data\n"; + my $rev = file_rev $p; + warn "store $p $rev size ", -s $p, " bytes | $data\n"; + $status = 201; # Created - + $json = { + id => $id, + ok => JSON::true, + rev => $rev, + }; + } elsif ( $method eq 'GET' ) { if ( ! -e $p ) { $status = 404; } else { warn "retrive $p ", -s $p, " bytes\n"; $json = Storable::retrieve( $p ); + if ( delete $arg->{revs_info} ) { + my $rev = file_rev $p; + $json->{_rev} = $rev; + $json->{_revs_info} = [ + { rev => $rev, status => 'available' } + ]; + } + $status = 200; + } } elsif ( $method eq 'DELETE' ) { if ( -e $p ) { - unlink $p || { $status = 500 }; + unlink $p && ok || { $status = 500 }; } else { $status = 404; } + } elsif ( $method eq 'POST' ) { + my $data = data_from_tx( $tx ); + + # FIXME implement real view server and return 200 + $json = { total_rows => 0, offset => 0 }; + $status = 202; + } else { $status = 501; } - warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg; + if ( keys %$arg ) { + warn "WARNING: arg left from $url = ",dump( $arg ),$/; + $status = 501; + } } @@ -281,7 +351,7 @@ $tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' ); $tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" ); - warn "INFO CouchDB API $method $url $status\n$body\n"; + print "$method $url $status\n$body\n"; warn "## headers ", $tx->res->headers->to_string; @@ -291,7 +361,7 @@ sub database_get { my ($db_name) = @_; - my $path = $config->{path}; + my $path = $config->{database}->{path} || die; warn "# collecting docs from $path/$db_name/*\n"; my @docs = glob "$path/$db_name/*"; my $json = {