/[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 1051 by dpavlin, Thu Apr 23 19:35:26 2009 UTC branches/zimbardo/lib/Frey/CouchAPI.pm revision 1172 by dpavlin, Sun Jul 5 21:40:16 2009 UTC
# Line 2  package Frey::CouchAPI; Line 2  package Frey::CouchAPI;
2    
3  =head1 DESCRIPTION  =head1 DESCRIPTION
4    
5  This is REST wrapper using L<Mojo::Transaction> to 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>
11    
12    L<Mojo::Transaction>
13    
14    
15  =head1 Supported HTTP API  =head1 Supported HTTP API
16    
# Line 14  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.1';  our $VERSION = '0.3';
29  $VERSION .= ' on Frey ' . $Frey::VERSION;  $VERSION .= " (Frey $Frey::VERSION)" if $Frey::VERSION;
30    
31  our $debug = $Frey::debug || 0;  our $debug = $Frey::debug || 0;
32    
# Line 37  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 = {};
57  our $status = 500;  our $status;
58    
59  sub ok {  sub ok {
60          $json = { ok => JSON::true };          $json = { ok => JSON::true };
61          $status = 200;          $status = 200;
62            warn "ok from ",join(' ',caller),$/;
63  }  }
64    
65    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    
78            $status = 500; # Internal Error
79    
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->{database}->{path};
84                    
85          if ( $url eq '/' ) {          if ( $url eq '/' ) {
86                  $json = {                  $json = {
87                          couchdb => "Welcome",                          couchdb => "Welcome",
88                          version => "CouchAPI $VERSION",                          version => "CouchAPI $VERSION",
89                  }                  };
90                    $status = 200;
91          } elsif ( $url eq '/_all_dbs' ) {          } elsif ( $url eq '/_all_dbs' ) {
92                  $json = [ @all_dbs ];                  $json = [
93                            map {
94                                    my $db = $_;
95                                    $db =~ s{^\Q$path\E/*}{};
96                                    $db;
97                            } glob $path . $config->{database}->{name_glob}
98                    ];
99                  $status = 200;                  $status = 200;
100          } elsif ( $url =~ m{^/_config/?(.+)} ) {          } elsif ( $url =~ m{^/_config/?(.+)} ) {
101    
102                  $json = { CouchAPI => $config };                  $json = $config;
103    
104                  if ( $method eq 'PUT' ) {                  if ( $method eq 'PUT' ) {
105    
106                          my $part = $1;                          my $part = $1;
107                          warn "## part $part";                          my $data = data_from_tx( $tx );
108                            warn "## part $part = $data\n";
109    
                         $part =~ s!^!->{'!;  
110                          $part =~ s!/!'}->{'!;                          $part =~ s!/!'}->{'!;
                         $part =~ s/$/'}/;  
111    
                         my $data = $tx->req->content->file->slurp;  
                         $data = JSON->new->allow_nonref->decode( $data );  
                         warn "## data ",dump( $data );  
112                          # poor man's transaction :-)                          # poor man's transaction :-)
113                          my $code = "\$json$part = \$data; \$config$part = \$data;";                          my $code = "\$config->{'$part'} = \$data;";
114                          eval $code;                          eval $code; ## no critic
115                          if ( $@ ) {                          if ( $@ ) {
116                                  warn "ERROR: $code -> $@";                                  warn "ERROR: $code -> $@";
117                                  $status = 500;                                  $status = 500;
# Line 98  sub dispatch { Line 119  sub dispatch {
119                                  $status = 200;                                  $status = 200;
120                          }                          }
121    
122  warn "json ",dump( $json ), " config ", dump( $config );                          warn "# config after $code is ",dump( $config ),$/;
123    
124                  } elsif ( $method eq 'GET' ) {                  } elsif ( $method eq 'GET' ) {
125                          $status = 200;                          $status = 200;
# Line 106  warn "json ",dump( $json ), " config ", Line 127  warn "json ",dump( $json ), " config ",
127                          $status = 501;                          $status = 501;
128                  }                  }
129    
         } elsif ( $url =~ m{($regex_dbs)/$} ) {  
   
130  =head2 Database  =head2 Database
131    
132  L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction  L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction
133    
134  =cut  =cut
135    
136            } elsif (
137                       $url =~ m{($regex_dbs)/$}
138                    # DELETE doesn't have trailing slash
139                    || $method eq 'DELETE' && $url =~ m{($regex_dbs)$}
140            ) {
141    
142                  my $database = $1;                  my $database = $1;
143                  my $dir = "$config->{path}/$database";  
144                    my $dir = "$path/$database";
145    
146                  if ( $method eq 'GET' ) {                  if ( $method eq 'GET' ) {
147                          $json = database_get( $database );                          $json = database_get( $database );
# Line 123  L<http://wiki.apache.org/couchdb/HTTP_da Line 149  L<http://wiki.apache.org/couchdb/HTTP_da
149                          if ( ! -e $dir ) {                          if ( ! -e $dir ) {
150                                  $status = 404;                                  $status = 404;
151                          } else {                          } else {
152                                  remove_tree($dir) && ok || { $status = 501 };                                  rmtree($dir);
153                                    if ( ! -d $dir ) {
154                                            ok;
155                                    } else {
156                                            $status = 500;
157                                    }
158                          }                          }
159                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
160                          if ( ! -e $dir ) {                          if ( -e $dir ) {
                                 make_path($dir) && ok && warn "created $dir" || { $status = 501 };  
                         } else {  
161                                  $status = 412;                                  $status = 412;
162                            } else {
163                                    mkpath($dir);
164                                    if ( -e $path ) {
165                                            ok;
166                                            $status = 201;
167                                    } else {
168                                            $status = 500;
169                                    }
170                          }                          }
171                  }                  }
172    
173                    warn "## database $database $status ",dump( $json );
174    
175          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
176                  my ($database,$id,$args) = ($1,$2,$3);                  my ($database,$id,$args) = ($1,$2,$3);
177    
# Line 151  L<http://wiki.apache.org/couchdb/HTTP_Do Line 190  L<http://wiki.apache.org/couchdb/HTTP_Do
190                          }                          }
191                  }                  }
192    
                 my $path = $config->{path};  
193                  warn "ERROR: path $path doesn't exist\n" unless -e $path;                  warn "ERROR: path $path doesn't exist\n" unless -e $path;
194    
195                  my $p = "$path/$database/$id";                  my $p = "$path/$database/$id";
196                  warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";                  warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";
197    
198    
199                  if ( $id =~ m{_all_docs(\w+)?$} ) {                  if ( $id =~ m{_all_docs(\w*)$} ) {
200    
201                          my $by = $1;                          my $by = $1;
202                          my $offset = 0;                          my $offset = 0;
203                          my $startkey = delete $arg->{startkey};                          my $startkey = delete $arg->{startkey};
204                               $startkey ||= delete $arg->{startkey_docid}; # XXX key == id
205                          my $endkey   = delete $arg->{endkey};                          my $endkey   = delete $arg->{endkey};
206                          my $limit    = delete $arg->{limit};                          my $limit    = delete $arg->{limit};
207                            my $skip     = delete $arg->{skip};
208                          my $total_rows = 0;                          my $total_rows = 0;
209                            my $collected_rows = 0;
210    
211                          my @docs = grep { length $_ } map {                          my @docs = grep { length($_) > 0 } map {        ## no critic
212                                  return '' if defined $limit && $total_rows == $limit;  
213                                    my $id = $_;
214                                    $total_rows++;
215                    
216                                  s{^$path/$database/}{};                                  if ( $limit > 0 && $collected_rows == $limit ) {
217                                  return '' if defined $endkey && $_ gt $endkey;                                          '';
218                                    } else {
219    
220                                            $id = s{^$path/$database/}{};
221    
222                                  if ( $startkey ) {                                          if ( defined $endkey && $id gt $endkey ) {
223                                          if ( $_ ge $startkey ) {                                                  '';
224                                                  $total_rows++;                                          } elsif ( $startkey ) {
225                                                  $_;                                                  if ( $id ge $startkey ) {
226                                                            $collected_rows++;
227                                                            $id;
228                                                    } else {
229                                                            $offset++;
230                                                            '';
231                                                    }
232                                          } else {                                          } else {
233                                                  $offset++;                                                  $collected_rows++;
234                                                  return '';                                                  $id;
235                                          }                                          }
                                 } else {  
                                         $total_rows++;  
                                         $_;  
236                                  }                                  }
237    
238                          } glob( "$path/$database/*" );                          } glob( "$path/$database/*" );
239    
240                            $offset += $skip if $skip;
241    
242                          warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;                          warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
243    
244                          $json = {                          $json = {
# Line 212  L<http://wiki.apache.org/couchdb/HTTP_Do Line 263  L<http://wiki.apache.org/couchdb/HTTP_Do
263                                          id => $id,                                          id => $id,
264                                          key => $id,                                          key => $id,
265                                          value => {                                          value => {
266                                                  rev => (stat($p))[9], # mtime                                                  rev => file_rev $p,
267                                          }                                          }
268                                  };                                  };
269                          }                          }
# Line 227  L<http://wiki.apache.org/couchdb/HTTP_Do Line 278  L<http://wiki.apache.org/couchdb/HTTP_Do
278                                  push @{ $json->{rows} }, $rows->{$id};                                  push @{ $json->{rows} }, $rows->{$id};
279                          }                          }
280    
281                            $status = 200;
282    
283                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
284                    
285                          warn "## ",dump( $tx->req ) if $debug;                          warn "## ",dump( $tx->req ) if $debug;
286    
287                          my $data = $tx->req->content->file->slurp;                          my $data = $tx->req->content->file->slurp;
288    
289                            my $db_path = "$path/$database";
290                            make_path $db_path unless -e $db_path;
291    
292                          Storable::store( from_json($data), $p );                          Storable::store( from_json($data), $p );
293                          warn "store $p ", -s $p, " bytes: $data\n";                          my $rev = file_rev $p;
294                            warn "store $p $rev size ", -s $p, " bytes | $data\n";
295    
296                            $status = 201; # Created
297                            $json = {
298                                    id => $id,
299                                    ok => JSON::true,
300                                    rev => $rev,
301                            };
302    
303                  } elsif ( $method eq 'GET' ) {                  } elsif ( $method eq 'GET' ) {
304                          if ( ! -e $p ) {                          if ( ! -e $p ) {
305                                  $status = 404;                                  $status = 404;
306                          } else {                          } else {
307                                  warn "retrive $p ", -s $p, " bytes\n";                                  warn "retrive $p ", -s $p, " bytes\n";
308                                  $json = Storable::retrieve( $p );                                  $json = Storable::retrieve( $p );
309                                    if ( delete $arg->{revs_info} ) {
310                                            my $rev = file_rev $p;
311                                            $json->{_rev} = $rev;
312                                            $json->{_revs_info} = [
313                                                    { rev => $rev, status => 'available' }
314                                            ];
315                                    }
316                                    $status = 200;
317    
318                          }                          }
319                  } elsif ( $method eq 'DELETE' ) {                  } elsif ( $method eq 'DELETE' ) {
320                          if ( -e $p ) {                          if ( -e $p ) {
321                                  unlink $p || { $status = 501 };                                  unlink $p && ok || { $status = 500 };
322                          } else {                          } else {
323                                  $status = 404;                                  $status = 404;
324                          }                          }
325                    } elsif ( $method eq 'POST' ) {
326                            my $data = data_from_tx( $tx );
327    
328                            # FIXME implement real view server and return 200
329                            $json = { total_rows => 0, offset => 0 };
330                            $status = 202;
331    
332                  } else {                  } else {
333                          $status = 501;                          $status = 501;
334                  }                  }
335    
336                  warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;                  if ( keys %$arg ) {
337                            warn "WARNING: arg left from $url = ",dump( $arg ),$/;
338                            $status = 501;
339                    }
340    
341          }          }
342    
343          if ( $status >= 400 && $status < 500 && ! defined $json) {          $json = { error => 'not_found', reason => 'Missing' } if $status == 404;
344                  $json = { error => 'not_found', reason => 'Missing' };  
345                  warn "fake $status";          if ( $method =~ m{(DELETE|PUT)} ) {
346                    $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs );
347          }          }
348    
349          $tx->res->code( $status );          $tx->res->code( $status );
350          $tx->res->headers->content_type( 'text/json' );          $tx->res->headers->content_type( 'text/plain;charset=utf-8' );
351          my $body = to_json $json;          my $body = to_json $json;
352          $tx->res->body( $body );          $tx->res->body( $body );
353          warn "CouchDB API: $method $url $status $body\n";          $tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' );
354            $tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" );
355    
356            print "$method $url $status\n$body\n";
357    
358            warn "## headers ", $tx->res->headers->to_string;
359    
360          return $tx;          return $tx;
361    
362  }  }
363    
364  sub database_get {  sub database_get {
365          my ($db_name) = @_;          my ($db_name) = @_;
366          my $path = $config->{path};          my $path = $config->{database}->{path} || die;
367          warn "# collecting docs from $path/$db_name/*\n";          warn "# collecting docs from $path/$db_name/*\n";
368          my @docs = glob "$path/$db_name/*";          my @docs = glob "$path/$db_name/*";
369          my $json = {          my $json = {
Legend:
Removed from v.1051  
changed lines
  Added in v.1172
  ViewVC Help
Powered by ViewVC 1.1.26