lib/Frey/CouchAPI.pm

package Frey::CouchAPI;

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

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

                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 [$args]\n";


                if ( $id =~ m{_all_docs(\w+)?$} ) {

                        my $by = $1;
                        my $offset = 0;
                        my $startkey = delete $arg->{startkey};
warn "STARTKEY: $startkey\n";
                        my $total_rows = 0;

                        my @docs = grep { length $_ } map {
                                s{^$path/$database/}{};
                                if ( $startkey ) {
                                        if ( $_ >= $startkey ) {
                                                $total_rows++;
                                                $_;
                                        } else {
                                                $offset++;
                                        }
                                } else {
                                        $total_rows++;
                                        $_;
                                }
                        } glob( "$path/$database/*" );

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