--- trunk/lib/Frey/CouchAPI.pm	2009/04/22 23:38:10	1047
+++ trunk/lib/Frey/CouchAPI.pm	2009/04/27 16:23:52	1062
@@ -1,11 +1,33 @@
 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.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/} ) {
@@ -20,42 +42,102 @@
 	}
 }
 
-my $path = '/data/webpac2/var/row';
-my @all_dbs = map {
-	s{^\Q$path\E/*}{};
-	$_;
-} glob "$path/*/*";
+our $config = {
+	database => {
+		path => '/data/webpac2/var/row',
+		name_glob => '/*/*',
+	}
+};
 
 my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
 
 our $json = {};
-our $stauts = 500;
+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;
-
-	warn "INFO: using Apache CouchDB emulation API\n";
-
+	my $path = $config->{database}->{path};
+	
 	if ( $url eq '/' ) {
 		$json = {
 			couchdb => "Welcome",
-			version => "0-Frey",
-		}
+			version => "CouchAPI $VERSION",
+		};
+		$status = 200;
 	} elsif ( $url eq '/_all_dbs' ) {
-		$json = [ @all_dbs ];
+		$json = [
+			map {
+				s{^\Q$path\E/*}{};
+				$_;
+			} glob $path . $config->{database}->{name_glob}
+		];
 		$status = 200;
-	} elsif ( $url =~ m{($regex_dbs)/$} ) {
+	} 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;
+			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' ) {
@@ -64,83 +146,220 @@
 			if ( ! -e $dir ) {
 				$status = 404;
 			} else {
-				remove_tree($dir) && ok || { $status = 501 };
+				remove_tree($dir);
+				if ( ! -d $dir ) {
+					ok;
+				} else {
+					$status = 500;
+				}
 			}
 		} elsif ( $method eq 'PUT' ) {
-			if ( ! -e $dir ) {
-				make_path($dir) && ok && warn "created $dir" || { $status = 501 };
-			} else {
+			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) = ($1,$2);
-	
+		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 ";
+		warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";
 
-		if ( $id eq '_all_docs' ) {
 
-			my @docs = map {
-				s{^$path/$database/}{};
-				$_;
+		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 $_ } map {
+
+				$total_rows++;
+	
+				if ( $limit > 0 && $collected_rows == $limit ) {
+					'';
+				} else {
+	
+					s{^$path/$database/}{};
+
+					if ( defined $endkey && $_ gt $endkey ) {
+						'';
+					} elsif ( $startkey ) {
+						if ( $_ ge $startkey ) {
+							$collected_rows++;
+							$_;
+						} else {
+							$offset++;
+							'';
+						}
+					} else {
+						$collected_rows++;
+						$_;
+					}
+				}
+
 			} glob( "$path/$database/*" );
 
-			warn "## docs ", dump( @docs );
+			$offset += $skip if $skip;
+
+			warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
 
 			$json = {
-				total_rows =>  $#docs + 1,
-				offset => 0,
+				total_rows =>  $total_rows,
+				offset => $offset,
 				rows => [],
 			};
 
+			my $rows;
+			my @ids;
+
 			foreach my $id ( @docs ) {
-				warn "++ $id\n";
+				warn "++ $id\n" if $debug;
 				my $p = "$path/$database/$id";
-				my $data = Storable::retrieve( $p );
-				push @{ $json->{rows} }, {
+				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
+						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 );
+			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 );
-			warn "store $p ", -s $p, " bytes: $data\n";
+			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' ) {
-			warn "retrive $p ", -s $p, " bytes\n";
-			$json = Storable::retrieve( $p );
+			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;
+		}
+
 	}
 
-	if ( $status >= 400 && $status < 500 && ! defined $json) {
-		$json = { error => 'not_found', reason => 'Missing' };
-		warn "fake $status";
+	$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/json' );
+	$tx->res->headers->content_type( 'text/plain;charset=utf-8' );
 	my $body = to_json $json;
 	$tx->res->body( $body );
-	warn "CouchDB API: $method $url $status $body\n";
+	$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->{database}->{path} || die;
 	warn "# collecting docs from $path/$db_name/*\n";
 	my @docs = glob "$path/$db_name/*";
 	my $json = {
@@ -155,9 +374,15 @@
 	};
 
 	warn "## calculating disk_size\n";
-	$json->{disk_size} += -s "$path/$1/$_" foreach $docs;
+	$json->{disk_size} += -s $_ foreach @docs;
 	$status = 200;
 	return $json;
 }
 
 1;
+__END__
+
+=head1 SEE ALSO
+
+L<http://wiki.apache.org/couchdb/Reference>
+