lib/Frey/CouchAPI.pm

package Frey::CouchAPI;

=head1 DESCRIPTION

This is REST wrapper using following L<Mojo> implement Apache's CouchDB API


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 qw(make_path remove_tree);
use Storable;

our $VERSION = '0.2';
$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 = {
        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;

sub ok {
        $json = { ok => JSON::true };
        $status = 200;
        warn "ok from ",join(' ',caller),$/;
}

sub file_rev { (stat($_[0]))[9] } # mtime

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->{path};
        
        if ( $url eq '/' ) {
                $json = {
                        couchdb => "Welcome",
                        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<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction

=cut

                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 {
                                remove_tree($dir);
                                if ( ! -d $dir ) {
                                        ok;
                                } else {
                                        $status = 500;
                                }
                        }
                } elsif ( $method eq 'PUT' ) {
                        if ( -e $dir ) {
                                $status = 412;
                        } else {
                                make_path($dir);
                                if ( -e $path ) {
                                        ok;
                                        $status = 201;
                                } else {
                                        $status = 500;
                                }
                        }
                }

        } 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};
                        my $endkey   = delete $arg->{endkey};
                        my $limit    = delete $arg->{limit};
                        my $total_rows = 0;

                        my @docs = grep { length $_ } map {

                                if ( $limit > 0 && $total_rows == $limit ) {
                                        '';
                                } else {
        
                                        s{^$path/$database/}{};

                                        if ( defined $endkey && $_ gt $endkey ) {
                                                '';
                                        } elsif ( $startkey ) {
                                                if ( $_ ge $startkey ) {
                                                        $total_rows++;
                                                        $_;
                                                } else {
                                                        $offset++;
                                                        '';
                                                }
                                        } 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 => 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;

                        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' ) {
                        $json = { total_rows => 0, offset => 0 };
                        $status = 202; # FIXME implement real view server and return 200
                } else {
                        $status = 501;
                }

                warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;

        }

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