package Frey::CouchAPI;
=head1 DESCRIPTION
This is REST wrapper using following L<Mojo> implement Apache's CouchDB API
You can access it using normal C</_utils/> URI, just like on real CouchDB and
it will bring up partially functional Futon interface against this module.
L<Mojo::URL>
L<Mojo::Transaction>
=head1 Supported HTTP API
=cut
use warnings;
use strict;
use JSON;
use Data::Dump qw/dump/;
use URI::Escape;
use File::Path;
use Storable;
our $VERSION = '0.3';
$VERSION .= " (Frey $Frey::VERSION)" if $Frey::VERSION;
our $debug = $Frey::debug || 0;
sub rewrite_urls {
my ( $self, $tx ) = @_;
if ( $tx->req->url->path =~ m{/_utils/} ) {
my $path = $tx->req->url->path;
$path =~ s{(/_utils)/?$}{$1/index.html}; # poor man's DirectoryIndex
$path =~ s{/_utils}{/static/futon};
$tx->req->url->path( $path );
my $url = $tx->req->url->to_string;
my $old = $url;
$url = $tx->req->url->to_string;
warn "# rewrite $old -> $url\n";
}
}
our $config = {
database => {
path => '/data/webpac2/var/row',
name_glob => '/*/*',
}
};
my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
our $json = {};
our $status;
sub ok {
$json = { ok => JSON::true };
$status = 200;
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) = @_;
$status = 500; # Internal Error
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 = {
couchdb => "Welcome",
version => "CouchAPI $VERSION",
};
$status = 200;
} elsif ( $url eq '/_all_dbs' ) {
$json = [
map {
my $db = $_;
$db =~ s{^\Q$path\E/*}{};
$db;
} glob $path . $config->{database}->{name_glob}
];
$status = 200;
} elsif ( $url =~ m{^/_config/?(.+)} ) {
$json = $config;
if ( $method eq 'PUT' ) {
my $part = $1;
my $data = data_from_tx( $tx );
warn "## part $part = $data\n";
$part =~ s!/!'}->{'!;
# poor man's transaction :-)
my $code = "\$config->{'$part'} = \$data;";
eval $code; ## no critic
if ( $@ ) {
warn "ERROR: $code -> $@";
$status = 500;
} else {
$status = 200;
}
warn "# config after $code is ",dump( $config ),$/;
} elsif ( $method eq 'GET' ) {
$status = 200;
} else {
$status = 501;
}
=head2 Database
L<http://wiki.apache.org/couchdb/HTTP_database_API> 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 = "$path/$database";
if ( $method eq 'GET' ) {
$json = database_get( $database );
} elsif ( $method eq 'DELETE' ) {
if ( ! -e $dir ) {
$status = 404;
} else {
rmtree($dir);
if ( ! -d $dir ) {
ok;
} else {
$status = 500;
}
}
} elsif ( $method eq 'PUT' ) {
if ( -e $dir ) {
$status = 412;
} else {
mkpath($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);
=head2 Document
L<http://wiki.apache.org/couchdb/HTTP_Document_API>
=cut
my $arg;
if ( $args ) {
foreach my $a ( split(/[&;]/,$args) ) {
my ($n,$v) = split(/=/,$a);
$v =~ s{(["'])(.+)\1}{$2};
$arg->{$n} = $v;
}
}
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*)$} ) {
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($_) > 0 } map { ## no critic
my $id = $_;
$total_rows++;
if ( $limit > 0 && $collected_rows == $limit ) {
'';
} else {
$id = s{^$path/$database/}{};
if ( defined $endkey && $id gt $endkey ) {
'';
} elsif ( $startkey ) {
if ( $id ge $startkey ) {
$collected_rows++;
$id;
} else {
$offset++;
'';
}
} else {
$collected_rows++;
$id;
}
}
} glob( "$path/$database/*" );
$offset += $skip if $skip;
warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
$json = {
total_rows => $total_rows,
offset => $offset,
rows => [],
};
my $rows;
my @ids;
foreach my $id ( @docs ) {
warn "++ $id\n" if $debug;
my $p = "$path/$database/$id";
my $data = eval { Storable::retrieve( $p ) };
if ( $@ ) {
warn "ERROR: $p | $@\n";
next;
}
push @ids, $id;
$rows->{$id} = {
id => $id,
key => $id,
value => {
rev => file_rev $p,
}
};
}
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};
}
$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 );
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 && 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;
}
if ( keys %$arg ) {
warn "WARNING: arg left from $url = ",dump( $arg ),$/;
$status = 501;
}
}
$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 );
$tx->res->headers->content_type( 'text/plain;charset=utf-8' );
my $body = to_json $json;
$tx->res->body( $body );
$tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' );
$tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" );
print "$method $url $status\n$body\n";
warn "## headers ", $tx->res->headers->to_string;
return $tx;
}
sub database_get {
my ($db_name) = @_;
my $path = $config->{database}->{path} || die;
warn "# collecting docs from $path/$db_name/*\n";
my @docs = glob "$path/$db_name/*";
my $json = {
db_name => $db_name,
doc_count => $#docs + 1,
doc_del_count => 0,
update_seq => 0,
purge_seq => 0,
capacity_running => JSON::false,
disk_size => 0,
instance_start_time => time(),
};
warn "## calculating disk_size\n";
$json->{disk_size} += -s $_ foreach @docs;
$status = 200;
return $json;
}
1;
__END__
=head1 SEE ALSO
L<http://wiki.apache.org/couchdb/Reference>
RSS Feed