lib/Frey/CouchAPI.pm

package Frey::CouchAPI;

=head1 DESCRIPTION

This is REST wrapper using L<Mojo::Transaction> to implement Apache's CouchDB API

=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/} ) {
                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 = {
        path => '/data/webpac2/var/row',
};

my $p = $config->{path};
my @all_dbs = map {
        s{^\Q$p\E/*}{};
        $_;
} glob "$p/*/*";

my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';

our $json = {};
our $status = 500;

sub ok {
        $json = { ok => JSON::true };
        $status = 200;
}


sub dispatch {
        my ($self,$tx) = @_;

        my $url = $tx->req->url->to_string;
        $url = uri_unescape( $url );
        my $method = $tx->req->method;
        
        if ( $url eq '/' ) {
                $json = {
                        couchdb => "Welcome",
                        version => "CouchAPI $VERSION",
                }
        } 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<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction

=cut

                my $database = $1;
                my $dir = "$config->{path}/$database";

                if ( $method eq 'GET' ) {
                        $json = database_get( $database );
                } elsif ( $method eq 'DELETE' ) {
                        if ( ! -e $dir ) {
                                $status = 404;
                        } else {
                                remove_tree($dir) && ok || { $status = 501 };
                        }
                } elsif ( $method eq 'PUT' ) {
                        if ( ! -e $dir ) {
                                make_path($dir) && ok && warn "created $dir" || { $status = 501 };
                        } else {
                                $status = 412;
                        }
                }

        } 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;
                        }
                }

                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+)?$} ) {

                        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 = 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 $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 => (stat($p))[9], # mtime
                                        }
                                };
                        }

                        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 ) if $debug;

                        my $data = $tx->req->content->file->slurp;

                        Storable::store( from_json($data), $p );
                        warn "store $p ", -s $p, " bytes: $data\n";
                } elsif ( $method eq 'GET' ) {
                        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 = 501 };
                        } 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";
        }

        $tx->res->code( $status );
        $tx->res->headers->content_type( 'text/json' );
        my $body = to_json $json;
        $tx->res->body( $body );
        warn "CouchDB API: $method $url $status $body\n";
        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 = {
                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>

1	dpavlin	1046	package Frey::CouchAPI;
2
3	dpavlin	1051	=head1 DESCRIPTION
4
5			This is REST wrapper using L<Mojo::Transaction> to implement Apache's CouchDB API
6
7			=head1 Supported HTTP API
8
9			=cut
10
11	dpavlin	1049	use warnings;
12			use strict;
13
14	dpavlin	1046	use JSON;
15			use Data::Dump qw/dump/;
16			use URI::Escape;
17	dpavlin	1047	use File::Path qw(make_path remove_tree);
18			use Storable;
19	dpavlin	1046
20	dpavlin	1049	our $VERSION = '0.1';
21	dpavlin	1050	$VERSION .= ' on Frey ' . $Frey::VERSION;
22	dpavlin	1049
23			our $debug = $Frey::debug \|\| 0;
24
25	dpavlin	1046	sub rewrite_urls {
26			my ( $self, $tx ) = @_;
27			if ( $tx->req->url->path =~ m{/_utils/} ) {
28			my $path = $tx->req->url->path;
29			$path =~ s{(/_utils)/?$}{$1/index.html}; # poor man's DirectoryIndex
30			$path =~ s{/_utils}{/static/futon};
31			$tx->req->url->path( $path );
32			my $url = $tx->req->url->to_string;
33			my $old = $url;
34			$url = $tx->req->url->to_string;
35			warn "# rewrite $old -> $url\n";
36			}
37			}
38
39	dpavlin	1050	our $config = {
40			path => '/data/webpac2/var/row',
41			};
42
43			my $p = $config->{path};
44	dpavlin	1046	my @all_dbs = map {
45	dpavlin	1050	s{^\Q$p\E/*}{};
46	dpavlin	1046	$_;
47	dpavlin	1050	} glob "$p//";
48	dpavlin	1046
49	dpavlin	1047	my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
50	dpavlin	1046
51	dpavlin	1047	our $json = {};
52	dpavlin	1049	our $status = 500;
53	dpavlin	1047
54			sub ok {
55			$json = { ok => JSON::true };
56			$status = 200;
57			}
58
59	dpavlin	1050
60	dpavlin	1046	sub dispatch {
61			my ($self,$tx) = @_;
62
63			my $url = $tx->req->url->to_string;
64			$url = uri_unescape( $url );
65	dpavlin	1047	my $method = $tx->req->method;
66	dpavlin	1050
67	dpavlin	1046	if ( $url eq '/' ) {
68			$json = {
69	dpavlin	1047	couchdb => "Welcome",
70	dpavlin	1050	version => "CouchAPI $VERSION",
71	dpavlin	1046	}
72			} elsif ( $url eq '/_all_dbs' ) {
73			$json = [ @all_dbs ];
74	dpavlin	1047	$status = 200;
75	dpavlin	1050	} elsif ( $url =~ m{^/_config/?(.+)} ) {
76
77			$json = { CouchAPI => $config };
78
79			if ( $method eq 'PUT' ) {
80
81			my $part = $1;
82			warn "## part $part";
83
84			$part =~ s!^!->{'!;
85			$part =~ s!/!'}->{'!;
86			$part =~ s/$/'}/;
87
88			my $data = $tx->req->content->file->slurp;
89			$data = JSON->new->allow_nonref->decode( $data );
90			warn "## data ",dump( $data );
91			# poor man's transaction :-)
92			my $code = "\$json$part = \$data; \$config$part = \$data;";
93			eval $code;
94			if ( $@ ) {
95			warn "ERROR: $code -> $@";
96			$status = 500;
97			} else {
98			$status = 200;
99	dpavlin	1049	}
100	dpavlin	1050
101			warn "json ",dump( $json ), " config ", dump( $config );
102
103			} elsif ( $method eq 'GET' ) {
104			$status = 200;
105			} else {
106			$status = 501;
107			}
108
109	dpavlin	1047	} elsif ( $url =~ m{($regex_dbs)/$} ) {
110	dpavlin	1046
111	dpavlin	1051	=head2 Database
112
113			L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction
114
115			=cut
116
117	dpavlin	1047	my $database = $1;
118	dpavlin	1050	my $dir = "$config->{path}/$database";
119	dpavlin	1047
120			if ( $method eq 'GET' ) {
121			$json = database_get( $database );
122			} elsif ( $method eq 'DELETE' ) {
123			if ( ! -e $dir ) {
124			$status = 404;
125			} else {
126			remove_tree($dir) && ok \|\| { $status = 501 };
127			}
128			} elsif ( $method eq 'PUT' ) {
129			if ( ! -e $dir ) {
130			make_path($dir) && ok && warn "created $dir" \|\| { $status = 501 };
131			} else {
132			$status = 412;
133			}
134			}
135
136	dpavlin	1049	} elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
137			my ($database,$id,$args) = ($1,$2,$3);
138
139	dpavlin	1051	=head2 Document
140
141			L<http://wiki.apache.org/couchdb/HTTP_Document_API>
142
143			=cut
144
145	dpavlin	1049	my $arg;
146			if ( $args ) {
147			foreach my $a ( split(/[&;]/,$args) ) {
148			my ($n,$v) = split(/=/,$a);
149			$v =~ s{(["'])(.+)\1}{$2};
150			$arg->{$n} = $v;
151			}
152			}
153	dpavlin	1050
154			my $path = $config->{path};
155			warn "ERROR: path $path doesn't exist\n" unless -e $path;
156
157	dpavlin	1047	my $p = "$path/$database/$id";
158	dpavlin	1051	warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";
159	dpavlin	1047
160
161	dpavlin	1049	if ( $id =~ m{_all_docs(\w+)?$} ) {
162
163			my $by = $1;
164			my $offset = 0;
165			my $startkey = delete $arg->{startkey};
166	dpavlin	1051	my $endkey = delete $arg->{endkey};
167			my $limit = delete $arg->{limit};
168	dpavlin	1049	my $total_rows = 0;
169
170			my @docs = grep { length $_ } map {
171	dpavlin	1051	return '' if defined $limit && $total_rows == $limit;
172
173	dpavlin	1047	s{^$path/$database/}{};
174	dpavlin	1051	return '' if defined $endkey && $_ gt $endkey;
175
176	dpavlin	1049	if ( $startkey ) {
177	dpavlin	1051	if ( $_ ge $startkey ) {
178	dpavlin	1049	$total_rows++;
179			$_;
180			} else {
181			$offset++;
182	dpavlin	1051	return '';
183	dpavlin	1049	}
184			} else {
185			$total_rows++;
186			$_;
187			}
188	dpavlin	1051
189	dpavlin	1047	} glob( "$path/$database/*" );
190
191	dpavlin	1051	warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
192	dpavlin	1047
193			$json = {
194	dpavlin	1049	total_rows => $total_rows,
195			offset => $offset,
196	dpavlin	1047	rows => [],
197			};
198
199	dpavlin	1049	my $rows;
200			my @ids;
201
202	dpavlin	1047	foreach my $id ( @docs ) {
203	dpavlin	1049	warn "++ $id\n" if $debug;
204	dpavlin	1047	my $p = "$path/$database/$id";
205	dpavlin	1049	my $data = eval { Storable::retrieve( $p ) };
206			if ( $@ ) {
207			warn "ERROR: $p \| $@\n";
208			next;
209			}
210			push @ids, $id;
211			$rows->{$id} = {
212	dpavlin	1047	id => $id,
213			key => $id,
214			value => {
215			rev => (stat($p))[9], # mtime
216			}
217			};
218			}
219
220	dpavlin	1049	my $descending = delete $arg->{descending};
221			my @sorted = sort @ids;
222
223	dpavlin	1050	warn "creating rows in ", $descending ? "descending" : "", " order\n";
224
225	dpavlin	1049	foreach my $id ( $descending ? reverse @sorted : @sorted ) {
226	dpavlin	1050	warn ">> $id ", $descending ? 'desc' : 'asc', "\n" if $debug;
227	dpavlin	1049	push @{ $json->{rows} }, $rows->{$id};
228			}
229
230	dpavlin	1047	} elsif ( $method eq 'PUT' ) {
231
232	dpavlin	1049	warn "## ",dump( $tx->req ) if $debug;
233	dpavlin	1047
234			my $data = $tx->req->content->file->slurp;
235
236			Storable::store( from_json($data), $p );
237			warn "store $p ", -s $p, " bytes: $data\n";
238			} elsif ( $method eq 'GET' ) {
239	dpavlin	1049	if ( ! -e $p ) {
240			$status = 404;
241			} else {
242			warn "retrive $p ", -s $p, " bytes\n";
243			$json = Storable::retrieve( $p );
244			}
245			} elsif ( $method eq 'DELETE' ) {
246			if ( -e $p ) {
247			unlink $p \|\| { $status = 501 };
248			} else {
249			$status = 404;
250			}
251	dpavlin	1047	} else {
252			$status = 501;
253			}
254
255	dpavlin	1049	warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;
256
257	dpavlin	1046	}
258
259	dpavlin	1047	if ( $status >= 400 && $status < 500 && ! defined $json) {
260			$json = { error => 'not_found', reason => 'Missing' };
261			warn "fake $status";
262			}
263
264			$tx->res->code( $status );
265	dpavlin	1046	$tx->res->headers->content_type( 'text/json' );
266	dpavlin	1047	my $body = to_json $json;
267			$tx->res->body( $body );
268			warn "CouchDB API: $method $url $status $body\n";
269	dpavlin	1046	return $tx;
270
271			}
272
273	dpavlin	1047	sub database_get {
274			my ($db_name) = @_;
275	dpavlin	1050	my $path = $config->{path};
276	dpavlin	1047	warn "# collecting docs from $path/$db_name/*\n";
277			my @docs = glob "$path/$db_name/*";
278			my $json = {
279			db_name => $db_name,
280			doc_count => $#docs + 1,
281			doc_del_count => 0,
282			update_seq => 0,
283			purge_seq => 0,
284			capacity_running => JSON::false,
285			disk_size => 0,
286			instance_start_time => time(),
287			};
288
289			warn "## calculating disk_size\n";
290	dpavlin	1049	$json->{disk_size} += -s $_ foreach @docs;
291	dpavlin	1047	$status = 200;
292			return $json;
293			}
294
295	dpavlin	1046	1;
296	dpavlin	1051	__END__
297
298			=head1 SEE ALSO
299
300			L<http://wiki.apache.org/couchdb/Reference>
301