/[Frey]/trunk/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 /trunk/lib/Frey/CouchAPI.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1047 by dpavlin, Wed Apr 22 23:38:10 2009 UTC revision 1056 by dpavlin, Thu Apr 23 21:24:25 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;
18    use strict;
19    
20  use JSON;  use JSON;
21  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
22  use URI::Escape;  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.2';
27    $VERSION .= " (Frey $Frey::VERSION)" if $Frey::VERSION;
28    
29    our $debug = $Frey::debug || 0;
30    
31  sub rewrite_urls {  sub rewrite_urls {
32          my ( $self, $tx ) = @_;          my ( $self, $tx ) = @_;
33          if ( $tx->req->url->path =~ m{/_utils/} ) {          if ( $tx->req->url->path =~ m{/_utils/} ) {
# Line 20  sub rewrite_urls { Line 42  sub rewrite_urls {
42          }          }
43  }  }
44    
45  my $path = '/data/webpac2/var/row';  our $config = {
46            path => '/data/webpac2/var/row',
47    };
48    
49    my $p = $config->{path};
50  my @all_dbs = map {  my @all_dbs = map {
51          s{^\Q$path\E/*}{};          s{^\Q$p\E/*}{};
52          $_;          $_;
53  } glob "$path/*/*";  } glob "$p/*/*";
54    
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 $stauts = 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          warn "INFO: using Apache CouchDB emulation API\n";          
   
78          if ( $url eq '/' ) {          if ( $url eq '/' ) {
79                  $json = {                  $json = {
80                          couchdb => "Welcome",                          couchdb => "Welcome",
81                          version => "0-Frey",                          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;
87            } elsif ( $url =~ m{^/_config/?(.+)} ) {
88    
89                    $json = { CouchAPI => $config };
90    
91                    if ( $method eq 'PUT' ) {
92    
93                            my $part = $1;
94                            warn "## part $part";
95    
96                            $part =~ s!^!->{'!;
97                            $part =~ s!/!'}->{'!;
98                            $part =~ s/$/'}/;
99    
100                            my $data = $tx->req->content->file->slurp;
101                            $data = JSON->new->allow_nonref->decode( $data );
102                            warn "## data ",dump( $data );
103                            # poor man's transaction :-)
104                            my $code = "\$json$part = \$data; \$config$part = \$data;";
105                            eval $code;
106                            if ( $@ ) {
107                                    warn "ERROR: $code -> $@";
108                                    $status = 500;
109                            } else {
110                                    $status = 200;
111                            }
112    
113    warn "json ",dump( $json ), " config ", dump( $config );
114    
115                    } elsif ( $method eq 'GET' ) {
116                            $status = 200;
117                    } else {
118                            $status = 501;
119                    }
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    
131                  my $dir = "$path/$database";                  my $dir = "$path/$database";
132    
133                  if ( $method eq 'GET' ) {                  if ( $method eq 'GET' ) {
# Line 64  sub dispatch { Line 136  sub dispatch {
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) = ($1,$2);                  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;
170                    if ( $args ) {
171                            foreach my $a ( split(/[&;]/,$args) ) {
172                                    my ($n,$v) = split(/=/,$a);
173                                    $v =~ s{(["'])(.+)\1}{$2};
174                                    $arg->{$n} = $v;
175                            }
176                    }
177    
178                    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 ";                  warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";
182    
183    
184                  if ( $id eq '_all_docs' ) {                  if ( $id =~ m{_all_docs(\w+)?$} ) {
185    
186                          my @docs = map {                          my $by = $1;
187                            my $offset = 0;
188                            my $startkey = delete $arg->{startkey};
189                            my $endkey   = delete $arg->{endkey};
190                            my $limit    = delete $arg->{limit};
191                            my $total_rows = 0;
192    
193                            my @docs = grep { length $_ } map {
194                                    return '' if defined $limit && $total_rows == $limit;
195            
196                                  s{^$path/$database/}{};                                  s{^$path/$database/}{};
197                                  $_;                                  return '' if defined $endkey && $_ gt $endkey;
198    
199                                    if ( $startkey ) {
200                                            if ( $_ ge $startkey ) {
201                                                    $total_rows++;
202                                                    $_;
203                                            } else {
204                                                    $offset++;
205                                                    return '';
206                                            }
207                                    } else {
208                                            $total_rows++;
209                                            $_;
210                                    }
211    
212                          } glob( "$path/$database/*" );                          } glob( "$path/$database/*" );
213    
214                          warn "## docs ", dump( @docs );                          warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
215    
216                          $json = {                          $json = {
217                                  total_rows =>  $#docs + 1,                                  total_rows =>  $total_rows,
218                                  offset => 0,                                  offset => $offset,
219                                  rows => [],                                  rows => [],
220                          };                          };
221    
222                            my $rows;
223                            my @ids;
224    
225                          foreach my $id ( @docs ) {                          foreach my $id ( @docs ) {
226                                  warn "++ $id\n";                                  warn "++ $id\n" if $debug;
227                                  my $p = "$path/$database/$id";                                  my $p = "$path/$database/$id";
228                                  my $data = Storable::retrieve( $p );                                  my $data = eval { Storable::retrieve( $p ) };
229                                  push @{ $json->{rows} }, {                                  if ( $@ ) {
230                                            warn "ERROR: $p | $@\n";
231                                            next;
232                                    }
233                                    push @ids, $id;
234                                    $rows->{$id} = {
235                                          id => $id,                                          id => $id,
236                                          key => $id,                                          key => $id,
237                                          value => {                                          value => {
238                                                  rev => (stat($p))[9], # mtime                                                  rev => file_rev $p,
239                                          }                                          }
240                                  };                                  };
241                          }                          }
242    
243                            my $descending = delete $arg->{descending};
244                            my @sorted = sort @ids;
245    
246                            warn "creating rows in ", $descending ? "descending" : "", " order\n";
247    
248                            foreach my $id ( $descending ? reverse @sorted : @sorted ) {
249                                    warn ">> $id ", $descending ? 'desc' : 'asc', "\n" if $debug;
250                                    push @{ $json->{rows} }, $rows->{$id};
251                            }
252    
253                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
254                    
255                          warn "## ",dump( $tx->req );                          warn "## ",dump( $tx->req ); # if $debug;
256    
257                          my $data = $tx->req->content->file->slurp;                          my $data = $tx->req->content->file->slurp;
258    
259                          Storable::store( from_json($data), $p );                          Storable::store( from_json($data), $p );
260                          warn "store $p ", -s $p, " bytes: $data\n";                          my $rev = file_rev $p;
261                            warn "store $p $rev size ", -s $p, " bytes | $data\n";
262    
263                            $status = 201; # Created
264                            $json = {
265                                    id => $id,
266                                    ok => JSON::true,
267                                    rev => $rev,
268                            };
269    
270                  } elsif ( $method eq 'GET' ) {                  } elsif ( $method eq 'GET' ) {
271                          warn "retrive $p ", -s $p, " bytes\n";                          if ( ! -e $p ) {
272                          $json = Storable::retrieve( $p );                                  $status = 404;
273                            } else {
274                                    warn "retrive $p ", -s $p, " bytes\n";
275                                    $json = Storable::retrieve( $p );
276                                    if ( delete $arg->{revs_info} ) {
277                                            my $rev = file_rev $p;
278                                            $json->{_rev} = $rev;
279                                            $json->{_revs_info} = [
280                                                    { rev => $rev, status => 'available' }
281                                            ];
282                                    }
283                                    $status = 200;
284    
285                            }
286                    } elsif ( $method eq 'DELETE' ) {
287                            if ( -e $p ) {
288                                    unlink $p && ok || { $status = 500 };
289                            } else {
290                                    $status = 404;
291                            }
292                    } elsif ( $method eq 'POST' ) {
293                            $json = { total_rows => 0, offset => 0 };
294                            $status = 202; # FIXME implement real view server and return 200
295                  } else {                  } else {
296                          $status = 501;                          $status = 501;
297                  }                  }
298    
299                    warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;
300    
301          }          }
302    
303          if ( $status >= 400 && $status < 500 && ! defined $json) {          $json = { error => 'not_found', reason => 'Missing' } if $status == 404;
304                  $json = { error => 'not_found', reason => 'Missing' };  
305                  warn "fake $status";          if ( $method =~ m{(DELETE|PUT)} ) {
306                    $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs );
307          }          }
308    
309          $tx->res->code( $status );          $tx->res->code( $status );
310          $tx->res->headers->content_type( 'text/json' );          $tx->res->headers->content_type( 'text/plain;charset=utf-8' );
311          my $body = to_json $json;          my $body = to_json $json;
312          $tx->res->body( $body );          $tx->res->body( $body );
313          warn "CouchDB API: $method $url $status $body\n";          $tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' );
314            $tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" );
315    
316            print "$method $url $status\n$body\n";
317    
318            warn "## headers ", $tx->res->headers->to_string;
319    
320          return $tx;          return $tx;
321    
322  }  }
323    
324  sub database_get {  sub database_get {
325          my ($db_name) = @_;          my ($db_name) = @_;
326            my $path = $config->{path};
327          warn "# collecting docs from $path/$db_name/*\n";          warn "# collecting docs from $path/$db_name/*\n";
328          my @docs = glob "$path/$db_name/*";          my @docs = glob "$path/$db_name/*";
329          my $json = {          my $json = {
# Line 155  sub database_get { Line 338  sub database_get {
338          };          };
339    
340          warn "## calculating disk_size\n";          warn "## calculating disk_size\n";
341          $json->{disk_size} += -s "$path/$1/$_" foreach $docs;          $json->{disk_size} += -s $_ foreach @docs;
342          $status = 200;          $status = 200;
343          return $json;          return $json;
344  }  }
345    
346  1;  1;
347    __END__
348    
349    =head1 SEE ALSO
350    
351    L<http://wiki.apache.org/couchdb/Reference>
352    
Legend:
Removed from v.1047  
changed lines
  Added in v.1056
  ViewVC Help
Powered by ViewVC 1.1.26