lib/Frey/CouchAPI.pm

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',
                database_glob => '*/*',
                data_glob => '*',
        }
};

$config = {
        data => {
                base_path => '/home/dpavlin/x/Frey/var/svn/home/dpavlin/private/svn',
                database => '*',
                files => '*.storable',
        },
};

sub _glob_databases {
        my $path = $config->{data}->{base_path};
        map {
                my $p = $_;
                $p =~ s{^$path/+}{};
                $p;
        } glob "$path/$config->{data}->{database}"
}

sub _glob_files {
        my $path = $config->{data}->{base_path} . '/' . shift;
        map {
                my $p = $_;
                $p =~ s{^$path/+}{};
                $p;
        } glob "$path/$config->{data}->{files}"
};

my $regex_dbs = '[a-zA-Z][a-zA-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->{data}->{base_path};

        die "base_path $path doesn't exist" unless -e $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_databases
                ];
                $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 {

                                        if ( defined $endkey && $id gt $endkey ) {
                                                '';
                                        } elsif ( $startkey ) {
                                                if ( $id ge $startkey ) {
                                                        $collected_rows++;
                                                        $id;
                                                } else {
                                                        $offset++;
                                                        '';
                                                }
                                        } else {
                                                $collected_rows++;
                                                $id;
                                        }
                                }

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