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 .= '-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";
        }
}

my $path = '/data/webpac2/var/ds';
my @all_dbs = map {
        s{^\Q$path\E/*}{};
        $_;
} glob "$path/*/*";

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 => $VERSION,
                }
        } elsif ( $url eq '/_all_dbs' ) {
                $json = [ @all_dbs ];
                $status = 200;
        } elsif ( $url =~ m{^/_config} ) {
                $json = {
                        couchdb => {
                                version => $VERSION,
                                path => $path,
                        }
                };
                $status = 200;
        } elsif ( $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 {
                                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 $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 );

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

                        foreach my $id ( $descending ? reverse @sorted : @sorted ) {
                                warn ">> $id ", $descending ? 'desc' : 'asc', "\n";
                                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) = @_;
        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			$VERSION .= '-Frey-' . $Frey::VERSION;
14
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	1049	my $path = '/data/webpac2/var/ds';
32	dpavlin	1046	my @all_dbs = map {
33			s{^\Q$path\E/*}{};
34			$_;
35			} glob "$path//";
36
37	dpavlin	1047	my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
38	dpavlin	1046
39	dpavlin	1047	our $json = {};
40	dpavlin	1049	our $status = 500;
41	dpavlin	1047
42			sub ok {
43			$json = { ok => JSON::true };
44			$status = 200;
45			}
46
47	dpavlin	1046	sub dispatch {
48			my ($self,$tx) = @_;
49
50			my $url = $tx->req->url->to_string;
51			$url = uri_unescape( $url );
52	dpavlin	1047	my $method = $tx->req->method;
53	dpavlin	1046
54			if ( $url eq '/' ) {
55			$json = {
56	dpavlin	1047	couchdb => "Welcome",
57	dpavlin	1049	version => $VERSION,
58	dpavlin	1046	}
59			} elsif ( $url eq '/_all_dbs' ) {
60			$json = [ @all_dbs ];
61	dpavlin	1047	$status = 200;
62	dpavlin	1049	} elsif ( $url =~ m{^/_config} ) {
63			$json = {
64			couchdb => {
65			version => $VERSION,
66			path => $path,
67			}
68			};
69			$status = 200;
70	dpavlin	1047	} elsif ( $url =~ m{($regex_dbs)/$} ) {
71	dpavlin	1046
72	dpavlin	1047	my $database = $1;
73			my $dir = "$path/$database";
74
75			if ( $method eq 'GET' ) {
76			$json = database_get( $database );
77			} elsif ( $method eq 'DELETE' ) {
78			if ( ! -e $dir ) {
79			$status = 404;
80			} else {
81			remove_tree($dir) && ok \|\| { $status = 501 };
82			}
83			} elsif ( $method eq 'PUT' ) {
84			if ( ! -e $dir ) {
85			make_path($dir) && ok && warn "created $dir" \|\| { $status = 501 };
86			} else {
87			$status = 412;
88			}
89			}
90
91	dpavlin	1049	} elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
92			my ($database,$id,$args) = ($1,$2,$3);
93
94			my $arg;
95			if ( $args ) {
96			foreach my $a ( split(/[&;]/,$args) ) {
97			my ($n,$v) = split(/=/,$a);
98			$v =~ s{(["'])(.+)\1}{$2};
99			$arg->{$n} = $v;
100			}
101			}
102	dpavlin	1047
103			my $p = "$path/$database/$id";
104	dpavlin	1049	warn "## database: $database id: $id -> $p [$args]\n";
105	dpavlin	1047
106
107	dpavlin	1049	if ( $id =~ m{_all_docs(\w+)?$} ) {
108
109			my $by = $1;
110			my $offset = 0;
111			my $startkey = delete $arg->{startkey};
112			warn "STARTKEY: $startkey\n";
113			my $total_rows = 0;
114
115			my @docs = grep { length $_ } map {
116	dpavlin	1047	s{^$path/$database/}{};
117	dpavlin	1049	if ( $startkey ) {
118			if ( $_ >= $startkey ) {
119			$total_rows++;
120			$_;
121			} else {
122			$offset++;
123			}
124			} else {
125			$total_rows++;
126			$_;
127			}
128	dpavlin	1047	} glob( "$path/$database/*" );
129
130			warn "## docs ", dump( @docs );
131
132			$json = {
133	dpavlin	1049	total_rows => $total_rows,
134			offset => $offset,
135	dpavlin	1047	rows => [],
136			};
137
138	dpavlin	1049	my $rows;
139			my @ids;
140
141	dpavlin	1047	foreach my $id ( @docs ) {
142	dpavlin	1049	warn "++ $id\n" if $debug;
143	dpavlin	1047	my $p = "$path/$database/$id";
144	dpavlin	1049	my $data = eval { Storable::retrieve( $p ) };
145			if ( $@ ) {
146			warn "ERROR: $p \| $@\n";
147			next;
148			}
149			push @ids, $id;
150			$rows->{$id} = {
151	dpavlin	1047	id => $id,
152			key => $id,
153			value => {
154			rev => (stat($p))[9], # mtime
155			}
156			};
157			}
158
159	dpavlin	1049	my $descending = delete $arg->{descending};
160			my @sorted = sort @ids;
161
162			foreach my $id ( $descending ? reverse @sorted : @sorted ) {
163			warn ">> $id ", $descending ? 'desc' : 'asc', "\n";
164			push @{ $json->{rows} }, $rows->{$id};
165			}
166
167	dpavlin	1047	} elsif ( $method eq 'PUT' ) {
168
169	dpavlin	1049	warn "## ",dump( $tx->req ) if $debug;
170	dpavlin	1047
171			my $data = $tx->req->content->file->slurp;
172
173			Storable::store( from_json($data), $p );
174			warn "store $p ", -s $p, " bytes: $data\n";
175			} elsif ( $method eq 'GET' ) {
176	dpavlin	1049	if ( ! -e $p ) {
177			$status = 404;
178			} else {
179			warn "retrive $p ", -s $p, " bytes\n";
180			$json = Storable::retrieve( $p );
181			}
182			} elsif ( $method eq 'DELETE' ) {
183			if ( -e $p ) {
184			unlink $p \|\| { $status = 501 };
185			} else {
186			$status = 404;
187			}
188	dpavlin	1047	} else {
189			$status = 501;
190			}
191
192	dpavlin	1049	warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;
193
194	dpavlin	1046	}
195
196	dpavlin	1047	if ( $status >= 400 && $status < 500 && ! defined $json) {
197			$json = { error => 'not_found', reason => 'Missing' };
198			warn "fake $status";
199			}
200
201			$tx->res->code( $status );
202	dpavlin	1046	$tx->res->headers->content_type( 'text/json' );
203	dpavlin	1047	my $body = to_json $json;
204			$tx->res->body( $body );
205			warn "CouchDB API: $method $url $status $body\n";
206	dpavlin	1046	return $tx;
207
208			}
209
210	dpavlin	1047	sub database_get {
211			my ($db_name) = @_;
212			warn "# collecting docs from $path/$db_name/*\n";
213			my @docs = glob "$path/$db_name/*";
214			my $json = {
215			db_name => $db_name,
216			doc_count => $#docs + 1,
217			doc_del_count => 0,
218			update_seq => 0,
219			purge_seq => 0,
220			capacity_running => JSON::false,
221			disk_size => 0,
222			instance_start_time => time(),
223			};
224
225			warn "## calculating disk_size\n";
226	dpavlin	1049	$json->{disk_size} += -s $_ foreach @docs;
227	dpavlin	1047	$status = 200;
228			return $json;
229			}
230
231	dpavlin	1046	1;