/[Frey]/branches/zimbardo/lib/Frey/CouchAPI.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /branches/zimbardo/lib/Frey/CouchAPI.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/lib/Frey/CouchAPI.pm revision 1059 by dpavlin, Fri Apr 24 15:32:04 2009 UTC branches/zimbardo/lib/Frey/CouchAPI.pm revision 1191 by dpavlin, Mon Sep 28 20:25:07 2009 UTC
# Line 4  package Frey::CouchAPI; Line 4  package Frey::CouchAPI;
4    
5  This is REST wrapper using following L<Mojo> implement Apache's CouchDB API  This is REST wrapper using following L<Mojo> implement Apache's CouchDB API
6    
7    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    
10  L<Mojo::URL>  L<Mojo::URL>
11    
# Line 20  use strict; Line 22  use strict;
22  use JSON;  use JSON;
23  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
24  use URI::Escape;  use URI::Escape;
25  use File::Path qw(make_path remove_tree);  use File::Path;
26  use Storable;  use Storable;
27    
28  our $VERSION = '0.2';  our $VERSION = '0.3';
29  $VERSION .= " (Frey $Frey::VERSION)" if $Frey::VERSION;  $VERSION .= " (Frey $Frey::VERSION)" if $Frey::VERSION;
30    
31  our $debug = $Frey::debug || 0;  our $debug = $Frey::debug || 0;
# Line 43  sub rewrite_urls { Line 45  sub rewrite_urls {
45  }  }
46    
47  our $config = {  our $config = {
48          path => '/data/webpac2/var/row',          database => {
49                    path => '/data/webpac2/var/row',
50                    database_glob => '*/*',
51                    data_glob => '*',
52            }
53    };
54    
55    $config = {
56            data => {
57                    base_path => '/home/dpavlin/x/Frey/var/svn/home/dpavlin/private/svn',
58                    database => '*',
59                    files => '*.storable',
60            },
61  };  };
62    
63  my $p = $config->{path};  sub _glob_databases {
64  my @all_dbs = map {          my $path = $config->{data}->{base_path};
65          s{^\Q$p\E/*}{};          map {
66          $_;                  my $p = $_;
67  } glob "$p/*/*";                  $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-z][a-z0-9_\$\(\)\+\-/]+';  my $regex_dbs = '[a-zA-Z][a-zA-Z0-9_\$\(\)\+\-/]+';
82    
83  our $json = {};  our $json = {};
84  our $status;  our $status;
# Line 65  sub ok { Line 91  sub ok {
91    
92  sub file_rev { (stat($_[0]))[9] } # mtime  sub file_rev { (stat($_[0]))[9] } # mtime
93    
94    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  sub dispatch {  sub dispatch {
103          my ($self,$tx) = @_;          my ($self,$tx) = @_;
104    
# Line 73  sub dispatch { Line 107  sub dispatch {
107          my $url = $tx->req->url->to_string;          my $url = $tx->req->url->to_string;
108          $url = uri_unescape( $url );          $url = uri_unescape( $url );
109          my $method = $tx->req->method;          my $method = $tx->req->method;
110          my $path = $config->{path};          my $path = $config->{data}->{base_path};
111            
112            die "base_path $path doesn't exist" unless -e $path;
113    
114          if ( $url eq '/' ) {          if ( $url eq '/' ) {
115                  $json = {                  $json = {
116                          couchdb => "Welcome",                          couchdb => "Welcome",
# Line 82  sub dispatch { Line 118  sub dispatch {
118                  };                  };
119                  $status = 200;                  $status = 200;
120          } elsif ( $url eq '/_all_dbs' ) {          } elsif ( $url eq '/_all_dbs' ) {
121                  $json = [ @all_dbs ];                  $json = [
122                            map {
123                                    my $db = $_;
124                                    $db =~ s{^\Q$path\E/*}{};
125                                    $db;
126                            } _glob_databases
127                    ];
128                  $status = 200;                  $status = 200;
129          } elsif ( $url =~ m{^/_config/?(.+)} ) {          } elsif ( $url =~ m{^/_config/?(.+)} ) {
130    
131                  $json = { CouchAPI => $config };                  $json = $config;
132    
133                  if ( $method eq 'PUT' ) {                  if ( $method eq 'PUT' ) {
134    
135                          my $part = $1;                          my $part = $1;
136                          warn "## part $part";                          my $data = data_from_tx( $tx );
137                            warn "## part $part = $data\n";
138    
                         $part =~ s!^!->{'!;  
139                          $part =~ s!/!'}->{'!;                          $part =~ s!/!'}->{'!;
                         $part =~ s/$/'}/;  
140    
                         my $data = $tx->req->content->file->slurp;  
                         $data = JSON->new->allow_nonref->decode( $data );  
                         warn "## data ",dump( $data );  
141                          # poor man's transaction :-)                          # poor man's transaction :-)
142                          my $code = "\$json$part = \$data; \$config$part = \$data;";                          my $code = "\$config->{'$part'} = \$data;";
143                          eval $code;                          eval $code; ## no critic
144                          if ( $@ ) {                          if ( $@ ) {
145                                  warn "ERROR: $code -> $@";                                  warn "ERROR: $code -> $@";
146                                  $status = 500;                                  $status = 500;
# Line 110  sub dispatch { Line 148  sub dispatch {
148                                  $status = 200;                                  $status = 200;
149                          }                          }
150    
151  warn "json ",dump( $json ), " config ", dump( $config );                          warn "# config after $code is ",dump( $config ),$/;
152    
153                  } elsif ( $method eq 'GET' ) {                  } elsif ( $method eq 'GET' ) {
154                          $status = 200;                          $status = 200;
# Line 140  L<http://wiki.apache.org/couchdb/HTTP_da Line 178  L<http://wiki.apache.org/couchdb/HTTP_da
178                          if ( ! -e $dir ) {                          if ( ! -e $dir ) {
179                                  $status = 404;                                  $status = 404;
180                          } else {                          } else {
181                                  remove_tree($dir);                                  rmtree($dir);
182                                  if ( ! -d $dir ) {                                  if ( ! -d $dir ) {
183                                          ok;                                          ok;
184                                  } else {                                  } else {
# Line 151  L<http://wiki.apache.org/couchdb/HTTP_da Line 189  L<http://wiki.apache.org/couchdb/HTTP_da
189                          if ( -e $dir ) {                          if ( -e $dir ) {
190                                  $status = 412;                                  $status = 412;
191                          } else {                          } else {
192                                  make_path($dir);                                  mkpath($dir);
193                                  if ( -e $path ) {                                  if ( -e $path ) {
194                                          ok;                                          ok;
195                                          $status = 201;                                          $status = 201;
# Line 192  L<http://wiki.apache.org/couchdb/HTTP_Do Line 230  L<http://wiki.apache.org/couchdb/HTTP_Do
230                          my $by = $1;                          my $by = $1;
231                          my $offset = 0;                          my $offset = 0;
232                          my $startkey = delete $arg->{startkey};                          my $startkey = delete $arg->{startkey};
233                               $startkey ||= delete $arg->{startkey_docid}; # XXX key == id
234                          my $endkey   = delete $arg->{endkey};                          my $endkey   = delete $arg->{endkey};
235                          my $limit    = delete $arg->{limit};                          my $limit    = delete $arg->{limit};
236                            my $skip     = delete $arg->{skip};
237                          my $total_rows = 0;                          my $total_rows = 0;
238                            my $collected_rows = 0;
239    
240                          my @docs = grep { length $_ } map {                          my @docs = grep { length($_) > 0 } map {        ## no critic
241    
242                                  if ( $limit > 0 && $total_rows == $limit ) {                                  my $id = $_;
243                                    $total_rows++;
244            
245                                    if ( $limit > 0 && $collected_rows == $limit ) {
246                                          '';                                          '';
247                                  } else {                                  } else {
           
                                         s{^$path/$database/}{};  
248    
249                                          if ( defined $endkey && $_ gt $endkey ) {                                          if ( defined $endkey && $id gt $endkey ) {
250                                                  '';                                                  '';
251                                          } elsif ( $startkey ) {                                          } elsif ( $startkey ) {
252                                                  if ( $_ ge $startkey ) {                                                  if ( $id ge $startkey ) {
253                                                          $total_rows++;                                                          $collected_rows++;
254                                                          $_;                                                          $id;
255                                                  } else {                                                  } else {
256                                                          $offset++;                                                          $offset++;
257                                                          '';                                                          '';
258                                                  }                                                  }
259                                          } else {                                          } else {
260                                                  $total_rows++;                                                  $collected_rows++;
261                                                  $_;                                                  $id;
262                                          }                                          }
263                                  }                                  }
264    
265                          } glob( "$path/$database/*" );                          } _glob_files( $database );
266    
267                            $offset += $skip if $skip;
268    
269                          warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;                          warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
270    
# Line 307  L<http://wiki.apache.org/couchdb/HTTP_Do Line 350  L<http://wiki.apache.org/couchdb/HTTP_Do
350                                  $status = 404;                                  $status = 404;
351                          }                          }
352                  } elsif ( $method eq 'POST' ) {                  } elsif ( $method eq 'POST' ) {
353                            my $data = data_from_tx( $tx );
354    
355                            # FIXME implement real view server and return 200
356                          $json = { total_rows => 0, offset => 0 };                          $json = { total_rows => 0, offset => 0 };
357                          $status = 202; # FIXME implement real view server and return 200                          $status = 202;
358    
359                  } else {                  } else {
360                          $status = 501;                          $status = 501;
361                  }                  }
# Line 323  L<http://wiki.apache.org/couchdb/HTTP_Do Line 370  L<http://wiki.apache.org/couchdb/HTTP_Do
370          $json = { error => 'not_found', reason => 'Missing' } if $status == 404;          $json = { error => 'not_found', reason => 'Missing' } if $status == 404;
371    
372          if ( $method =~ m{(DELETE|PUT)} ) {          if ( $method =~ m{(DELETE|PUT)} ) {
373                  $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs );  #               $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs );
374          }          }
375    
376          $tx->res->code( $status );          $tx->res->code( $status );
377          $tx->res->headers->content_type( 'text/plain;charset=utf-8' );          $tx->res->headers->content_type( 'text/plain;charset=utf-8' );
378          my $body = to_json $json;          my $body = to_json $json;
379          $tx->res->body( $body );          $tx->res->body( $body );
380          $tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' );  #       $tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' );
381          $tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" );  #       $tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" );
382    
383          print "$method $url $status\n$body\n";          print "$method $url $status\n$body\n";
384    
# Line 343  L<http://wiki.apache.org/couchdb/HTTP_Do Line 390  L<http://wiki.apache.org/couchdb/HTTP_Do
390    
391  sub database_get {  sub database_get {
392          my ($db_name) = @_;          my ($db_name) = @_;
393          my $path = $config->{path};          warn "# collecting docs for $db_name\n";
394          warn "# collecting docs from $path/$db_name/*\n";          my @docs = _glob_files( $db_name );
395          my @docs = glob "$path/$db_name/*";          warn dump @docs;
396          my $json = {          my $json = {
397                  db_name => $db_name,                  db_name => $db_name,
398                  doc_count => $#docs + 1,                  doc_count => $#docs + 1,
Legend:
Removed from v.1059  
changed lines
  Added in v.1191
  ViewVC Help
Powered by ViewVC 1.1.26