/[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 1049 by dpavlin, Thu Apr 23 17:26:04 2009 UTC revision 1062 by dpavlin, Mon Apr 27 16:23:52 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.3';
27  $VERSION .= '-Frey-' . $Frey::VERSION;  $VERSION .= " (Frey $Frey::VERSION)" if $Frey::VERSION;
28    
29  our $debug = $Frey::debug || 0;  our $debug = $Frey::debug || 0;
30    
# Line 28  sub rewrite_urls { Line 42  sub rewrite_urls {
42          }          }
43  }  }
44    
45  my $path = '/data/webpac2/var/ds';  our $config = {
46  my @all_dbs = map {          database => {
47          s{^\Q$path\E/*}{};                  path => '/data/webpac2/var/row',
48          $_;                  name_glob => '/*/*',
49  } glob "$path/*/*";          }
50    };
51    
52  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
53    
54  our $json = {};  our $json = {};
55  our $status = 500;  our $status;
56    
57  sub ok {  sub ok {
58          $json = { ok => JSON::true };          $json = { ok => JSON::true };
59          $status = 200;          $status = 200;
60            warn "ok from ",join(' ',caller),$/;
61    }
62    
63    sub file_rev { (stat($_[0]))[9] } # mtime
64    
65    sub data_from_tx {
66            my $tx = shift;
67            my $data = $tx->req->content->file->slurp;
68            $data = JSON->new->allow_nonref->decode( $data );
69            warn "## data ",dump( $data );
70            return $data;
71  }  }
72    
73  sub dispatch {  sub dispatch {
74          my ($self,$tx) = @_;          my ($self,$tx) = @_;
75    
76            $status = 500; # Internal Error
77    
78          my $url = $tx->req->url->to_string;          my $url = $tx->req->url->to_string;
79          $url = uri_unescape( $url );          $url = uri_unescape( $url );
80          my $method = $tx->req->method;          my $method = $tx->req->method;
81            my $path = $config->{database}->{path};
82            
83          if ( $url eq '/' ) {          if ( $url eq '/' ) {
84                  $json = {                  $json = {
85                          couchdb => "Welcome",                          couchdb => "Welcome",
86                          version => $VERSION,                          version => "CouchAPI $VERSION",
87                  }                  };
88                    $status = 200;
89          } elsif ( $url eq '/_all_dbs' ) {          } elsif ( $url eq '/_all_dbs' ) {
90                  $json = [ @all_dbs ];                  $json = [
91                            map {
92                                    s{^\Q$path\E/*}{};
93                                    $_;
94                            } glob $path . $config->{database}->{name_glob}
95                    ];
96                  $status = 200;                  $status = 200;
97          } elsif ( $url =~ m{^/_config} ) {          } elsif ( $url =~ m{^/_config/?(.+)} ) {
98                  $json = {  
99                          couchdb => {                  $json = $config;
100                                  version => $VERSION,  
101                                  path => $path,                  if ( $method eq 'PUT' ) {
102    
103                            my $part = $1;
104                            my $data = data_from_tx( $tx );
105                            warn "## part $part = $data\n";
106    
107                            $part =~ s!/!'}->{'!;
108    
109                            # poor man's transaction :-)
110                            my $code = "\$config->{'$part'} = \$data;";
111                            eval $code;
112                            if ( $@ ) {
113                                    warn "ERROR: $code -> $@";
114                                    $status = 500;
115                            } else {
116                                    $status = 200;
117                          }                          }
118                  };  
119                  $status = 200;                          warn "# config after $code is ",dump( $config ),$/;
120          } elsif ( $url =~ m{($regex_dbs)/$} ) {  
121                    } elsif ( $method eq 'GET' ) {
122                            $status = 200;
123                    } else {
124                            $status = 501;
125                    }
126    
127    =head2 Database
128    
129    L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction
130    
131    =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    
141                  my $dir = "$path/$database";                  my $dir = "$path/$database";
142    
143                  if ( $method eq 'GET' ) {                  if ( $method eq 'GET' ) {
# Line 78  sub dispatch { Line 146  sub dispatch {
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    
175    =head2 Document
176    
177    L<http://wiki.apache.org/couchdb/HTTP_Document_API>
178    
179    =cut
180    
181                  my $arg;                  my $arg;
182                  if ( $args ) {                  if ( $args ) {
183                          foreach my $a ( split(/[&;]/,$args) ) {                          foreach my $a ( split(/[&;]/,$args) ) {
# Line 99  sub dispatch { Line 186  sub dispatch {
186                                  $arg->{$n} = $v;                                  $arg->{$n} = $v;
187                          }                          }
188                  }                  }
189            
190                    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 [$args]\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  warn "STARTKEY: $startkey\n";                             $startkey ||= delete $arg->{startkey_docid}; # XXX key == id
202                            my $endkey   = delete $arg->{endkey};
203                            my $limit    = delete $arg->{limit};
204                            my $skip     = delete $arg->{skip};
205                          my $total_rows = 0;                          my $total_rows = 0;
206                            my $collected_rows = 0;
207    
208                          my @docs = grep { length $_ } map {                          my @docs = grep { length $_ } map {
209                                  s{^$path/$database/}{};  
210                                  if ( $startkey ) {                                  $total_rows++;
211                                          if ( $_ >= $startkey ) {          
212                                                  $total_rows++;                                  if ( $limit > 0 && $collected_rows == $limit ) {
213                                                  $_;                                          '';
214                                    } else {
215            
216                                            s{^$path/$database/}{};
217    
218                                            if ( defined $endkey && $_ gt $endkey ) {
219                                                    '';
220                                            } elsif ( $startkey ) {
221                                                    if ( $_ ge $startkey ) {
222                                                            $collected_rows++;
223                                                            $_;
224                                                    } else {
225                                                            $offset++;
226                                                            '';
227                                                    }
228                                          } else {                                          } else {
229                                                  $offset++;                                                  $collected_rows++;
230                                                    $_;
231                                          }                                          }
                                 } else {  
                                         $total_rows++;  
                                         $_;  
232                                  }                                  }
233    
234                          } glob( "$path/$database/*" );                          } glob( "$path/$database/*" );
235    
236                          warn "## docs ", dump( @docs );                          $offset += $skip if $skip;
237    
238                            warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
239    
240                          $json = {                          $json = {
241                                  total_rows =>  $total_rows,                                  total_rows =>  $total_rows,
# Line 151  warn "STARTKEY: $startkey\n"; Line 259  warn "STARTKEY: $startkey\n";
259                                          id => $id,                                          id => $id,
260                                          key => $id,                                          key => $id,
261                                          value => {                                          value => {
262                                                  rev => (stat($p))[9], # mtime                                                  rev => file_rev $p,
263                                          }                                          }
264                                  };                                  };
265                          }                          }
# Line 159  warn "STARTKEY: $startkey\n"; Line 267  warn "STARTKEY: $startkey\n";
267                          my $descending = delete $arg->{descending};                          my $descending = delete $arg->{descending};
268                          my @sorted = sort @ids;                          my @sorted = sort @ids;
269    
270                            warn "creating rows in ", $descending ? "descending" : "", " order\n";
271    
272                          foreach my $id ( $descending ? reverse @sorted : @sorted ) {                          foreach my $id ( $descending ? reverse @sorted : @sorted ) {
273                                  warn ">> $id ", $descending ? 'desc' : 'asc', "\n";                                  warn ">> $id ", $descending ? 'desc' : 'asc', "\n" if $debug;
274                                  push @{ $json->{rows} }, $rows->{$id};                                  push @{ $json->{rows} }, $rows->{$id};
275                          }                          }
276    
277                            $status = 200;
278    
279                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
280                    
281                          warn "## ",dump( $tx->req ) if $debug;                          warn "## ",dump( $tx->req ) if $debug;
282    
283                          my $data = $tx->req->content->file->slurp;                          my $data = $tx->req->content->file->slurp;
284    
285                            my $db_path = "$path/$database";
286                            make_path $db_path unless -e $db_path;
287    
288                          Storable::store( from_json($data), $p );                          Storable::store( from_json($data), $p );
289                          warn "store $p ", -s $p, " bytes: $data\n";                          my $rev = file_rev $p;
290                            warn "store $p $rev size ", -s $p, " bytes | $data\n";
291    
292                            $status = 201; # Created
293                            $json = {
294                                    id => $id,
295                                    ok => JSON::true,
296                                    rev => $rev,
297                            };
298    
299                  } elsif ( $method eq 'GET' ) {                  } elsif ( $method eq 'GET' ) {
300                          if ( ! -e $p ) {                          if ( ! -e $p ) {
301                                  $status = 404;                                  $status = 404;
302                          } else {                          } else {
303                                  warn "retrive $p ", -s $p, " bytes\n";                                  warn "retrive $p ", -s $p, " bytes\n";
304                                  $json = Storable::retrieve( $p );                                  $json = Storable::retrieve( $p );
305                                    if ( delete $arg->{revs_info} ) {
306                                            my $rev = file_rev $p;
307                                            $json->{_rev} = $rev;
308                                            $json->{_revs_info} = [
309                                                    { rev => $rev, status => 'available' }
310                                            ];
311                                    }
312                                    $status = 200;
313    
314                          }                          }
315                  } elsif ( $method eq 'DELETE' ) {                  } elsif ( $method eq 'DELETE' ) {
316                          if ( -e $p ) {                          if ( -e $p ) {
317                                  unlink $p || { $status = 501 };                                  unlink $p && ok || { $status = 500 };
318                          } else {                          } else {
319                                  $status = 404;                                  $status = 404;
320                          }                          }
321                    } elsif ( $method eq 'POST' ) {
322                            my $data = data_from_tx( $tx );
323    
324                            # FIXME implement real view server and return 200
325                            $json = { total_rows => 0, offset => 0 };
326                            $status = 202;
327    
328                  } else {                  } else {
329                          $status = 501;                          $status = 501;
330                  }                  }
331    
332                  warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;                  if ( keys %$arg ) {
333                            warn "WARNING: arg left from $url = ",dump( $arg ),$/;
334                            $status = 501;
335                    }
336    
337          }          }
338    
339          if ( $status >= 400 && $status < 500 && ! defined $json) {          $json = { error => 'not_found', reason => 'Missing' } if $status == 404;
340                  $json = { error => 'not_found', reason => 'Missing' };  
341                  warn "fake $status";          if ( $method =~ m{(DELETE|PUT)} ) {
342                    $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs );
343          }          }
344    
345          $tx->res->code( $status );          $tx->res->code( $status );
346          $tx->res->headers->content_type( 'text/json' );          $tx->res->headers->content_type( 'text/plain;charset=utf-8' );
347          my $body = to_json $json;          my $body = to_json $json;
348          $tx->res->body( $body );          $tx->res->body( $body );
349          warn "CouchDB API: $method $url $status $body\n";          $tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' );
350            $tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" );
351    
352            print "$method $url $status\n$body\n";
353    
354            warn "## headers ", $tx->res->headers->to_string;
355    
356          return $tx;          return $tx;
357    
358  }  }
359    
360  sub database_get {  sub database_get {
361          my ($db_name) = @_;          my ($db_name) = @_;
362            my $path = $config->{database}->{path} || die;
363          warn "# collecting docs from $path/$db_name/*\n";          warn "# collecting docs from $path/$db_name/*\n";
364          my @docs = glob "$path/$db_name/*";          my @docs = glob "$path/$db_name/*";
365          my $json = {          my $json = {
# Line 229  sub database_get { Line 380  sub database_get {
380  }  }
381    
382  1;  1;
383    __END__
384    
385    =head1 SEE ALSO
386    
387    L<http://wiki.apache.org/couchdb/Reference>
388    
Legend:
Removed from v.1049  
changed lines
  Added in v.1062
  ViewVC Help
Powered by ViewVC 1.1.26