/[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 1051 by dpavlin, Thu Apr 23 19:35:26 2009 UTC revision 1060 by dpavlin, Fri Apr 24 17:41:45 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    
8    L<Mojo::URL>
9    
10    L<Mojo::Transaction>
11    
12    
13  =head1 Supported HTTP API  =head1 Supported HTTP API
14    
# Line 17  use URI::Escape; Line 23  use URI::Escape;
23  use File::Path qw(make_path remove_tree);  use File::Path qw(make_path remove_tree);
24  use Storable;  use Storable;
25    
26  our $VERSION = '0.1';  our $VERSION = '0.2';
27  $VERSION .= ' on Frey ' . $Frey::VERSION;  $VERSION .= " (Frey $Frey::VERSION)" if $Frey::VERSION;
28    
29  our $debug = $Frey::debug || 0;  our $debug = $Frey::debug || 0;
30    
# Line 49  my @all_dbs = map { Line 55  my @all_dbs = map {
55  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
56    
57  our $json = {};  our $json = {};
58  our $status = 500;  our $status;
59    
60  sub ok {  sub ok {
61          $json = { ok => JSON::true };          $json = { ok => JSON::true };
62          $status = 200;          $status = 200;
63            warn "ok from ",join(' ',caller),$/;
64  }  }
65    
66    sub file_rev { (stat($_[0]))[9] } # mtime
67    
68    sub data_from_tx {
69            my $tx = shift;
70            my $data = $tx->req->content->file->slurp;
71            $data = JSON->new->allow_nonref->decode( $data );
72            warn "## data ",dump( $data );
73            return $data;
74    }
75    
76  sub dispatch {  sub dispatch {
77          my ($self,$tx) = @_;          my ($self,$tx) = @_;
78    
79            $status = 500; # Internal Error
80    
81          my $url = $tx->req->url->to_string;          my $url = $tx->req->url->to_string;
82          $url = uri_unescape( $url );          $url = uri_unescape( $url );
83          my $method = $tx->req->method;          my $method = $tx->req->method;
84            my $path = $config->{path};
85                    
86          if ( $url eq '/' ) {          if ( $url eq '/' ) {
87                  $json = {                  $json = {
88                          couchdb => "Welcome",                          couchdb => "Welcome",
89                          version => "CouchAPI $VERSION",                          version => "CouchAPI $VERSION",
90                  }                  };
91                    $status = 200;
92          } elsif ( $url eq '/_all_dbs' ) {          } elsif ( $url eq '/_all_dbs' ) {
93                  $json = [ @all_dbs ];                  $json = [ @all_dbs ];
94                  $status = 200;                  $status = 200;
# Line 85  sub dispatch { Line 105  sub dispatch {
105                          $part =~ s!/!'}->{'!;                          $part =~ s!/!'}->{'!;
106                          $part =~ s/$/'}/;                          $part =~ s/$/'}/;
107    
108                          my $data = $tx->req->content->file->slurp;                          my $data = data_from_tx( $tx );
                         $data = JSON->new->allow_nonref->decode( $data );  
                         warn "## data ",dump( $data );  
109                          # poor man's transaction :-)                          # poor man's transaction :-)
110                          my $code = "\$json$part = \$data; \$config$part = \$data;";                          my $code = "\$json$part = \$data; \$config$part = \$data;";
111                          eval $code;                          eval $code;
# Line 106  warn "json ",dump( $json ), " config ", Line 124  warn "json ",dump( $json ), " config ",
124                          $status = 501;                          $status = 501;
125                  }                  }
126    
         } elsif ( $url =~ m{($regex_dbs)/$} ) {  
   
127  =head2 Database  =head2 Database
128    
129  L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction  L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction
130    
131  =cut  =cut
132    
133            } elsif (
134                       $url =~ m{($regex_dbs)/$}
135                    # DELETE doesn't have trailing slash
136                    || $method eq 'DELETE' && $url =~ m{($regex_dbs)$}
137            ) {
138    
139                  my $database = $1;                  my $database = $1;
140                  my $dir = "$config->{path}/$database";  
141                    my $dir = "$path/$database";
142    
143                  if ( $method eq 'GET' ) {                  if ( $method eq 'GET' ) {
144                          $json = database_get( $database );                          $json = database_get( $database );
# Line 123  L<http://wiki.apache.org/couchdb/HTTP_da Line 146  L<http://wiki.apache.org/couchdb/HTTP_da
146                          if ( ! -e $dir ) {                          if ( ! -e $dir ) {
147                                  $status = 404;                                  $status = 404;
148                          } else {                          } else {
149                                  remove_tree($dir) && ok || { $status = 501 };                                  remove_tree($dir);
150                                    if ( ! -d $dir ) {
151                                            ok;
152                                    } else {
153                                            $status = 500;
154                                    }
155                          }                          }
156                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
157                          if ( ! -e $dir ) {                          if ( -e $dir ) {
                                 make_path($dir) && ok && warn "created $dir" || { $status = 501 };  
                         } else {  
158                                  $status = 412;                                  $status = 412;
159                            } else {
160                                    make_path($dir);
161                                    if ( -e $path ) {
162                                            ok;
163                                            $status = 201;
164                                    } else {
165                                            $status = 500;
166                                    }
167                          }                          }
168                  }                  }
169    
170                    warn "## database $database $status ",dump( $json );
171    
172          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
173                  my ($database,$id,$args) = ($1,$2,$3);                  my ($database,$id,$args) = ($1,$2,$3);
174    
# Line 151  L<http://wiki.apache.org/couchdb/HTTP_Do Line 187  L<http://wiki.apache.org/couchdb/HTTP_Do
187                          }                          }
188                  }                  }
189    
                 my $path = $config->{path};  
190                  warn "ERROR: path $path doesn't exist\n" unless -e $path;                  warn "ERROR: path $path doesn't exist\n" unless -e $path;
191    
192                  my $p = "$path/$database/$id";                  my $p = "$path/$database/$id";
193                  warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";                  warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";
194    
195    
196                  if ( $id =~ m{_all_docs(\w+)?$} ) {                  if ( $id =~ m{_all_docs(\w*)$} ) {
197    
198                          my $by = $1;                          my $by = $1;
199                          my $offset = 0;                          my $offset = 0;
200                          my $startkey = delete $arg->{startkey};                          my $startkey = delete $arg->{startkey};
201                          my $endkey   = delete $arg->{endkey};                          my $endkey   = delete $arg->{endkey};
202                          my $limit    = delete $arg->{limit};                          my $limit    = delete $arg->{limit};
203                            my $skip     = delete $arg->{skip};
204                          my $total_rows = 0;                          my $total_rows = 0;
205    
206                          my @docs = grep { length $_ } map {                          my @docs = grep { length $_ } map {
207                                  return '' if defined $limit && $total_rows == $limit;  
208                                    if ( $limit > 0 && $total_rows == $limit ) {
209                                            '';
210                                    } else {
211                    
212                                  s{^$path/$database/}{};                                          s{^$path/$database/}{};
                                 return '' if defined $endkey && $_ gt $endkey;  
213    
214                                  if ( $startkey ) {                                          if ( defined $endkey && $_ gt $endkey ) {
215                                          if ( $_ ge $startkey ) {                                                  '';
216                                            } elsif ( $startkey ) {
217                                                    if ( $_ ge $startkey ) {
218                                                            $total_rows++;
219                                                            $_;
220                                                    } else {
221                                                            $offset++;
222                                                            '';
223                                                    }
224                                            } else {
225                                                  $total_rows++;                                                  $total_rows++;
226                                                  $_;                                                  $_;
                                         } else {  
                                                 $offset++;  
                                                 return '';  
227                                          }                                          }
                                 } else {  
                                         $total_rows++;  
                                         $_;  
228                                  }                                  }
229    
230                          } glob( "$path/$database/*" );                          } glob( "$path/$database/*" );
231    
232                            $offset += $skip if $skip;
233    
234                          warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;                          warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
235    
236                          $json = {                          $json = {
# Line 212  L<http://wiki.apache.org/couchdb/HTTP_Do Line 255  L<http://wiki.apache.org/couchdb/HTTP_Do
255                                          id => $id,                                          id => $id,
256                                          key => $id,                                          key => $id,
257                                          value => {                                          value => {
258                                                  rev => (stat($p))[9], # mtime                                                  rev => file_rev $p,
259                                          }                                          }
260                                  };                                  };
261                          }                          }
# Line 227  L<http://wiki.apache.org/couchdb/HTTP_Do Line 270  L<http://wiki.apache.org/couchdb/HTTP_Do
270                                  push @{ $json->{rows} }, $rows->{$id};                                  push @{ $json->{rows} }, $rows->{$id};
271                          }                          }
272    
273                            $status = 200;
274    
275                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
276                    
277                          warn "## ",dump( $tx->req ) if $debug;                          warn "## ",dump( $tx->req ) if $debug;
278    
279                          my $data = $tx->req->content->file->slurp;                          my $data = $tx->req->content->file->slurp;
280    
281                            my $db_path = "$path/$database";
282                            make_path $db_path unless -e $db_path;
283    
284                          Storable::store( from_json($data), $p );                          Storable::store( from_json($data), $p );
285                          warn "store $p ", -s $p, " bytes: $data\n";                          my $rev = file_rev $p;
286                            warn "store $p $rev size ", -s $p, " bytes | $data\n";
287    
288                            $status = 201; # Created
289                            $json = {
290                                    id => $id,
291                                    ok => JSON::true,
292                                    rev => $rev,
293                            };
294    
295                  } elsif ( $method eq 'GET' ) {                  } elsif ( $method eq 'GET' ) {
296                          if ( ! -e $p ) {                          if ( ! -e $p ) {
297                                  $status = 404;                                  $status = 404;
298                          } else {                          } else {
299                                  warn "retrive $p ", -s $p, " bytes\n";                                  warn "retrive $p ", -s $p, " bytes\n";
300                                  $json = Storable::retrieve( $p );                                  $json = Storable::retrieve( $p );
301                                    if ( delete $arg->{revs_info} ) {
302                                            my $rev = file_rev $p;
303                                            $json->{_rev} = $rev;
304                                            $json->{_revs_info} = [
305                                                    { rev => $rev, status => 'available' }
306                                            ];
307                                    }
308                                    $status = 200;
309    
310                          }                          }
311                  } elsif ( $method eq 'DELETE' ) {                  } elsif ( $method eq 'DELETE' ) {
312                          if ( -e $p ) {                          if ( -e $p ) {
313                                  unlink $p || { $status = 501 };                                  unlink $p && ok || { $status = 500 };
314                          } else {                          } else {
315                                  $status = 404;                                  $status = 404;
316                          }                          }
317                    } elsif ( $method eq 'POST' ) {
318                            my $data = data_from_tx( $tx );
319    
320                            # FIXME implement real view server and return 200
321                            $json = { total_rows => 0, offset => 0 };
322                            $status = 202;
323    
324                  } else {                  } else {
325                          $status = 501;                          $status = 501;
326                  }                  }
327    
328                  warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;                  if ( keys %$arg ) {
329                            warn "WARNING: arg left from $url = ",dump( $arg ),$/;
330                            $status = 501;
331                    }
332    
333          }          }
334    
335          if ( $status >= 400 && $status < 500 && ! defined $json) {          $json = { error => 'not_found', reason => 'Missing' } if $status == 404;
336                  $json = { error => 'not_found', reason => 'Missing' };  
337                  warn "fake $status";          if ( $method =~ m{(DELETE|PUT)} ) {
338                    $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs );
339          }          }
340    
341          $tx->res->code( $status );          $tx->res->code( $status );
342          $tx->res->headers->content_type( 'text/json' );          $tx->res->headers->content_type( 'text/plain;charset=utf-8' );
343          my $body = to_json $json;          my $body = to_json $json;
344          $tx->res->body( $body );          $tx->res->body( $body );
345          warn "CouchDB API: $method $url $status $body\n";          $tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' );
346            $tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" );
347    
348            print "$method $url $status\n$body\n";
349    
350            warn "## headers ", $tx->res->headers->to_string;
351    
352          return $tx;          return $tx;
353    
354  }  }
Legend:
Removed from v.1051  
changed lines
  Added in v.1060
  ViewVC Help
Powered by ViewVC 1.1.26