/[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 1050 by dpavlin, Thu Apr 23 18:45:42 2009 UTC revision 1057 by dpavlin, Thu Apr 23 22:18:46 2009 UTC
# Line 1  Line 1 
1  package Frey::CouchAPI;  package Frey::CouchAPI;
2    
3    =head1 DESCRIPTION
4    
5    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
14    
15    =cut
16    
17  use warnings;  use warnings;
18  use strict;  use strict;
19    
# Line 9  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 41  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 dispatch {  sub dispatch {
69          my ($self,$tx) = @_;          my ($self,$tx) = @_;
70    
71            $status = 500; # Internal Error
72    
73          my $url = $tx->req->url->to_string;          my $url = $tx->req->url->to_string;
74          $url = uri_unescape( $url );          $url = uri_unescape( $url );
75          my $method = $tx->req->method;          my $method = $tx->req->method;
76            my $path = $config->{path};
77                    
78          if ( $url eq '/' ) {          if ( $url eq '/' ) {
79                  $json = {                  $json = {
80                          couchdb => "Welcome",                          couchdb => "Welcome",
81                          version => "CouchAPI $VERSION",                          version => "CouchAPI $VERSION",
82                  }                  };
83                    $status = 200;
84          } elsif ( $url eq '/_all_dbs' ) {          } elsif ( $url eq '/_all_dbs' ) {
85                  $json = [ @all_dbs ];                  $json = [ @all_dbs ];
86                  $status = 200;                  $status = 200;
# Line 100  warn "json ",dump( $json ), " config ", Line 120  warn "json ",dump( $json ), " config ",
120    
121          } elsif ( $url =~ m{($regex_dbs)/$} ) {          } elsif ( $url =~ m{($regex_dbs)/$} ) {
122    
123    =head2 Database
124    
125    L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction
126    
127    =cut
128    
129                  my $database = $1;                  my $database = $1;
130                  my $dir = "$config->{path}/$database";  
131                    my $dir = "$path/$database";
132    
133                  if ( $method eq 'GET' ) {                  if ( $method eq 'GET' ) {
134                          $json = database_get( $database );                          $json = database_get( $database );
# Line 109  warn "json ",dump( $json ), " config ", Line 136  warn "json ",dump( $json ), " config ",
136                          if ( ! -e $dir ) {                          if ( ! -e $dir ) {
137                                  $status = 404;                                  $status = 404;
138                          } else {                          } else {
139                                  remove_tree($dir) && ok || { $status = 501 };                                  remove_tree($dir);
140                                    if ( ! -d $dir ) {
141                                            ok;
142                                    } else {
143                                            $status = 500;
144                                    }
145                          }                          }
146                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
147                          if ( ! -e $dir ) {                          if ( -e $dir ) {
                                 make_path($dir) && ok && warn "created $dir" || { $status = 501 };  
                         } else {  
148                                  $status = 412;                                  $status = 412;
149                            } else {
150                                    make_path($dir);
151                                    if ( -e $path ) {
152                                            ok;
153                                            $status = 201;
154                                    } else {
155                                            $status = 500;
156                                    }
157                          }                          }
158                  }                  }
159    
160          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
161                  my ($database,$id,$args) = ($1,$2,$3);                  my ($database,$id,$args) = ($1,$2,$3);
162    
163    =head2 Document
164    
165    L<http://wiki.apache.org/couchdb/HTTP_Document_API>
166    
167    =cut
168    
169                  my $arg;                  my $arg;
170                  if ( $args ) {                  if ( $args ) {
171                          foreach my $a ( split(/[&;]/,$args) ) {                          foreach my $a ( split(/[&;]/,$args) ) {
# Line 131  warn "json ",dump( $json ), " config ", Line 175  warn "json ",dump( $json ), " config ",
175                          }                          }
176                  }                  }
177    
                 my $path = $config->{path};  
178                  warn "ERROR: path $path doesn't exist\n" unless -e $path;                  warn "ERROR: path $path doesn't exist\n" unless -e $path;
179    
180                  my $p = "$path/$database/$id";                  my $p = "$path/$database/$id";
181                  warn "## database: $database id: $id -> $p [$args]\n";                  warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";
182    
183    
184                  if ( $id =~ m{_all_docs(\w+)?$} ) {                  if ( $id =~ m{_all_docs(\w*)$} ) {
185    
186                          my $by = $1;                          my $by = $1;
187                          my $offset = 0;                          my $offset = 0;
188                          my $startkey = delete $arg->{startkey};                          my $startkey = delete $arg->{startkey};
189  warn "STARTKEY: $startkey\n";                          my $endkey   = delete $arg->{endkey};
190                            my $limit    = delete $arg->{limit};
191                          my $total_rows = 0;                          my $total_rows = 0;
192    
193                          my @docs = grep { length $_ } map {                          my @docs = grep { length $_ } map {
194                                  s{^$path/$database/}{};  
195                                  if ( $startkey ) {                                  if ( $limit > 0 && $total_rows == $limit ) {
196                                          if ( $_ >= $startkey ) {                                          '';
197                                    } else {
198            
199                                            s{^$path/$database/}{};
200    
201                                            if ( defined $endkey && $_ gt $endkey ) {
202                                                    '';
203                                            } elsif ( $startkey ) {
204                                                    if ( $_ ge $startkey ) {
205                                                            $total_rows++;
206                                                            $_;
207                                                    } else {
208                                                            $offset++;
209                                                            '';
210                                                    }
211                                            } else {
212                                                  $total_rows++;                                                  $total_rows++;
213                                                  $_;                                                  $_;
                                         } else {  
                                                 $offset++;  
214                                          }                                          }
                                 } else {  
                                         $total_rows++;  
                                         $_;  
215                                  }                                  }
216    
217                          } glob( "$path/$database/*" );                          } glob( "$path/$database/*" );
218    
219                          warn "## docs ", dump( @docs ) if $debug;  
220                            warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
221    
222                          $json = {                          $json = {
223                                  total_rows =>  $total_rows,                                  total_rows =>  $total_rows,
# Line 185  warn "STARTKEY: $startkey\n"; Line 241  warn "STARTKEY: $startkey\n";
241                                          id => $id,                                          id => $id,
242                                          key => $id,                                          key => $id,
243                                          value => {                                          value => {
244                                                  rev => (stat($p))[9], # mtime                                                  rev => file_rev $p,
245                                          }                                          }
246                                  };                                  };
247                          }                          }
# Line 200  warn "STARTKEY: $startkey\n"; Line 256  warn "STARTKEY: $startkey\n";
256                                  push @{ $json->{rows} }, $rows->{$id};                                  push @{ $json->{rows} }, $rows->{$id};
257                          }                          }
258    
259                            $status = 200;
260    
261                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
262                    
263                          warn "## ",dump( $tx->req ) if $debug;                          warn "## ",dump( $tx->req ); # if $debug;
264    
265                          my $data = $tx->req->content->file->slurp;                          my $data = $tx->req->content->file->slurp;
266    
267                          Storable::store( from_json($data), $p );                          Storable::store( from_json($data), $p );
268                          warn "store $p ", -s $p, " bytes: $data\n";                          my $rev = file_rev $p;
269                            warn "store $p $rev size ", -s $p, " bytes | $data\n";
270    
271                            $status = 201; # Created
272                            $json = {
273                                    id => $id,
274                                    ok => JSON::true,
275                                    rev => $rev,
276                            };
277    
278                  } elsif ( $method eq 'GET' ) {                  } elsif ( $method eq 'GET' ) {
279                          if ( ! -e $p ) {                          if ( ! -e $p ) {
280                                  $status = 404;                                  $status = 404;
281                          } else {                          } else {
282                                  warn "retrive $p ", -s $p, " bytes\n";                                  warn "retrive $p ", -s $p, " bytes\n";
283                                  $json = Storable::retrieve( $p );                                  $json = Storable::retrieve( $p );
284                                    if ( delete $arg->{revs_info} ) {
285                                            my $rev = file_rev $p;
286                                            $json->{_rev} = $rev;
287                                            $json->{_revs_info} = [
288                                                    { rev => $rev, status => 'available' }
289                                            ];
290                                    }
291                                    $status = 200;
292    
293                          }                          }
294                  } elsif ( $method eq 'DELETE' ) {                  } elsif ( $method eq 'DELETE' ) {
295                          if ( -e $p ) {                          if ( -e $p ) {
296                                  unlink $p || { $status = 501 };                                  unlink $p && ok || { $status = 500 };
297                          } else {                          } else {
298                                  $status = 404;                                  $status = 404;
299                          }                          }
300                    } elsif ( $method eq 'POST' ) {
301                            $json = { total_rows => 0, offset => 0 };
302                            $status = 202; # FIXME implement real view server and return 200
303                  } else {                  } else {
304                          $status = 501;                          $status = 501;
305                  }                  }
# Line 229  warn "STARTKEY: $startkey\n"; Line 308  warn "STARTKEY: $startkey\n";
308    
309          }          }
310    
311          if ( $status >= 400 && $status < 500 && ! defined $json) {          $json = { error => 'not_found', reason => 'Missing' } if $status == 404;
312                  $json = { error => 'not_found', reason => 'Missing' };  
313                  warn "fake $status";          if ( $method =~ m{(DELETE|PUT)} ) {
314                    $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs );
315          }          }
316    
317          $tx->res->code( $status );          $tx->res->code( $status );
318          $tx->res->headers->content_type( 'text/json' );          $tx->res->headers->content_type( 'text/plain;charset=utf-8' );
319          my $body = to_json $json;          my $body = to_json $json;
320          $tx->res->body( $body );          $tx->res->body( $body );
321          warn "CouchDB API: $method $url $status $body\n";          $tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' );
322            $tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" );
323    
324            print "$method $url $status\n$body\n";
325    
326            warn "## headers ", $tx->res->headers->to_string;
327    
328          return $tx;          return $tx;
329    
330  }  }
# Line 266  sub database_get { Line 352  sub database_get {
352  }  }
353    
354  1;  1;
355    __END__
356    
357    =head1 SEE ALSO
358    
359    L<http://wiki.apache.org/couchdb/Reference>
360    
Legend:
Removed from v.1050  
changed lines
  Added in v.1057
  ViewVC Help
Powered by ViewVC 1.1.26