/[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

revision 1057 by dpavlin, Thu Apr 23 22:18:46 2009 UTC revision 1071 by dpavlin, Tue Apr 28 16:38:18 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 23  use URI::Escape; Line 25  use URI::Escape;
25  use File::Path qw(make_path remove_tree);  use File::Path qw(make_path remove_tree);
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                    name_glob => '/*/*',
51            }
52  };  };
53    
 my $p = $config->{path};  
 my @all_dbs = map {  
         s{^\Q$p\E/*}{};  
         $_;  
 } glob "$p/*/*";  
   
54  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
55    
56  our $json = {};  our $json = {};
# Line 65  sub ok { Line 64  sub ok {
64    
65  sub file_rev { (stat($_[0]))[9] } # mtime  sub file_rev { (stat($_[0]))[9] } # mtime
66    
67    sub data_from_tx {
68            my $tx = shift;
69            my $data = $tx->req->content->file->slurp;
70            $data = JSON->new->allow_nonref->decode( $data );
71            warn "## data ",dump( $data );
72            return $data;
73    }
74    
75  sub dispatch {  sub dispatch {
76          my ($self,$tx) = @_;          my ($self,$tx) = @_;
77    
# Line 73  sub dispatch { Line 80  sub dispatch {
80          my $url = $tx->req->url->to_string;          my $url = $tx->req->url->to_string;
81          $url = uri_unescape( $url );          $url = uri_unescape( $url );
82          my $method = $tx->req->method;          my $method = $tx->req->method;
83          my $path = $config->{path};          my $path = $config->{database}->{path};
84                    
85          if ( $url eq '/' ) {          if ( $url eq '/' ) {
86                  $json = {                  $json = {
# Line 82  sub dispatch { Line 89  sub dispatch {
89                  };                  };
90                  $status = 200;                  $status = 200;
91          } elsif ( $url eq '/_all_dbs' ) {          } elsif ( $url eq '/_all_dbs' ) {
92                  $json = [ @all_dbs ];                  $json = [
93                            map {
94                                    s{^\Q$path\E/*}{};
95                                    $_;
96                            } glob $path . $config->{database}->{name_glob}
97                    ];
98                  $status = 200;                  $status = 200;
99          } elsif ( $url =~ m{^/_config/?(.+)} ) {          } elsif ( $url =~ m{^/_config/?(.+)} ) {
100    
101                  $json = { CouchAPI => $config };                  $json = $config;
102    
103                  if ( $method eq 'PUT' ) {                  if ( $method eq 'PUT' ) {
104    
105                          my $part = $1;                          my $part = $1;
106                          warn "## part $part";                          my $data = data_from_tx( $tx );
107                            warn "## part $part = $data\n";
108    
                         $part =~ s!^!->{'!;  
109                          $part =~ s!/!'}->{'!;                          $part =~ s!/!'}->{'!;
                         $part =~ s/$/'}/;  
110    
                         my $data = $tx->req->content->file->slurp;  
                         $data = JSON->new->allow_nonref->decode( $data );  
                         warn "## data ",dump( $data );  
111                          # poor man's transaction :-)                          # poor man's transaction :-)
112                          my $code = "\$json$part = \$data; \$config$part = \$data;";                          my $code = "\$config->{'$part'} = \$data;";
113                          eval $code;                          eval $code;
114                          if ( $@ ) {                          if ( $@ ) {
115                                  warn "ERROR: $code -> $@";                                  warn "ERROR: $code -> $@";
# Line 110  sub dispatch { Line 118  sub dispatch {
118                                  $status = 200;                                  $status = 200;
119                          }                          }
120    
121  warn "json ",dump( $json ), " config ", dump( $config );                          warn "# config after $code is ",dump( $config ),$/;
122    
123                  } elsif ( $method eq 'GET' ) {                  } elsif ( $method eq 'GET' ) {
124                          $status = 200;                          $status = 200;
# Line 118  warn "json ",dump( $json ), " config ", Line 126  warn "json ",dump( $json ), " config ",
126                          $status = 501;                          $status = 501;
127                  }                  }
128    
         } elsif ( $url =~ m{($regex_dbs)/$} ) {  
   
129  =head2 Database  =head2 Database
130    
131  L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction  L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction
132    
133  =cut  =cut
134    
135            } elsif (
136                       $url =~ m{($regex_dbs)/$}
137                    # DELETE doesn't have trailing slash
138                    || $method eq 'DELETE' && $url =~ m{($regex_dbs)$}
139            ) {
140    
141                  my $database = $1;                  my $database = $1;
142    
143                  my $dir = "$path/$database";                  my $dir = "$path/$database";
# Line 157  L<http://wiki.apache.org/couchdb/HTTP_da Line 169  L<http://wiki.apache.org/couchdb/HTTP_da
169                          }                          }
170                  }                  }
171    
172                    warn "## database $database $status ",dump( $json );
173    
174          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
175                  my ($database,$id,$args) = ($1,$2,$3);                  my ($database,$id,$args) = ($1,$2,$3);
176    
# Line 186  L<http://wiki.apache.org/couchdb/HTTP_Do Line 200  L<http://wiki.apache.org/couchdb/HTTP_Do
200                          my $by = $1;                          my $by = $1;
201                          my $offset = 0;                          my $offset = 0;
202                          my $startkey = delete $arg->{startkey};                          my $startkey = delete $arg->{startkey};
203                               $startkey ||= delete $arg->{startkey_docid}; # XXX key == id
204                          my $endkey   = delete $arg->{endkey};                          my $endkey   = delete $arg->{endkey};
205                          my $limit    = delete $arg->{limit};                          my $limit    = delete $arg->{limit};
206                            my $skip     = delete $arg->{skip};
207                          my $total_rows = 0;                          my $total_rows = 0;
208                            my $collected_rows = 0;
209    
210                          my @docs = grep { length $_ } map {                          my @docs = grep { length $_ } map {
211    
212                                  if ( $limit > 0 && $total_rows == $limit ) {                                  $total_rows++;
213            
214                                    if ( $limit > 0 && $collected_rows == $limit ) {
215                                          '';                                          '';
216                                  } else {                                  } else {
217                    
# Line 202  L<http://wiki.apache.org/couchdb/HTTP_Do Line 221  L<http://wiki.apache.org/couchdb/HTTP_Do
221                                                  '';                                                  '';
222                                          } elsif ( $startkey ) {                                          } elsif ( $startkey ) {
223                                                  if ( $_ ge $startkey ) {                                                  if ( $_ ge $startkey ) {
224                                                          $total_rows++;                                                          $collected_rows++;
225                                                          $_;                                                          $_;
226                                                  } else {                                                  } else {
227                                                          $offset++;                                                          $offset++;
228                                                          '';                                                          '';
229                                                  }                                                  }
230                                          } else {                                          } else {
231                                                  $total_rows++;                                                  $collected_rows++;
232                                                  $_;                                                  $_;
233                                          }                                          }
234                                  }                                  }
235    
236                          } glob( "$path/$database/*" );                          } glob( "$path/$database/*" );
237    
238                            $offset += $skip if $skip;
239    
240                          warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;                          warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
241    
# Line 260  L<http://wiki.apache.org/couchdb/HTTP_Do Line 280  L<http://wiki.apache.org/couchdb/HTTP_Do
280    
281                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
282                    
283                          warn "## ",dump( $tx->req ); # if $debug;                          warn "## ",dump( $tx->req ) if $debug;
284    
285                          my $data = $tx->req->content->file->slurp;                          my $data = $tx->req->content->file->slurp;
286    
287                            my $db_path = "$path/$database";
288                            make_path $db_path unless -e $db_path;
289    
290                          Storable::store( from_json($data), $p );                          Storable::store( from_json($data), $p );
291                          my $rev = file_rev $p;                          my $rev = file_rev $p;
292                          warn "store $p $rev size ", -s $p, " bytes | $data\n";                          warn "store $p $rev size ", -s $p, " bytes | $data\n";
# Line 298  L<http://wiki.apache.org/couchdb/HTTP_Do Line 321  L<http://wiki.apache.org/couchdb/HTTP_Do
321                                  $status = 404;                                  $status = 404;
322                          }                          }
323                  } elsif ( $method eq 'POST' ) {                  } elsif ( $method eq 'POST' ) {
324                            my $data = data_from_tx( $tx );
325    
326                            # FIXME implement real view server and return 200
327                          $json = { total_rows => 0, offset => 0 };                          $json = { total_rows => 0, offset => 0 };
328                          $status = 202; # FIXME implement real view server and return 200                          $status = 202;
329    
330                  } else {                  } else {
331                          $status = 501;                          $status = 501;
332                  }                  }
333    
334                  warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;                  if ( keys %$arg ) {
335                            warn "WARNING: arg left from $url = ",dump( $arg ),$/;
336                            $status = 501;
337                    }
338    
339          }          }
340    
# Line 331  L<http://wiki.apache.org/couchdb/HTTP_Do Line 361  L<http://wiki.apache.org/couchdb/HTTP_Do
361    
362  sub database_get {  sub database_get {
363          my ($db_name) = @_;          my ($db_name) = @_;
364          my $path = $config->{path};          my $path = $config->{database}->{path} || die;
365          warn "# collecting docs from $path/$db_name/*\n";          warn "# collecting docs from $path/$db_name/*\n";
366          my @docs = glob "$path/$db_name/*";          my @docs = glob "$path/$db_name/*";
367          my $json = {          my $json = {
Legend:
Removed from v.1057  
changed lines
  Added in v.1071
  ViewVC Help
Powered by ViewVC 1.1.26