/[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 1046 by dpavlin, Wed Apr 22 22:01:06 2009 UTC revision 1059 by dpavlin, Fri Apr 24 15:32:04 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);
24    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 ) = @_;
# Line 18  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 = join('|', @all_dbs);  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
56    
57    our $json = {};
58    our $status;
59    
60    sub ok {
61            $json = { ok => JSON::true };
62            $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;
76            my $path = $config->{path};
77            
78            if ( $url eq '/' ) {
79                    $json = {
80                            couchdb => "Welcome",
81                            version => "CouchAPI $VERSION",
82                    };
83                    $status = 200;
84            } elsif ( $url eq '/_all_dbs' ) {
85                    $json = [ @all_dbs ];
86                    $status = 200;
87            } elsif ( $url =~ m{^/_config/?(.+)} ) {
88    
89          warn "INFO: using Apache CouchDB emulation API $url\n";                  $json = { CouchAPI => $config };
90    
91          warn "## tx = ",dump( $tx );                  if ( $method eq 'PUT' ) {
92    
93          my $json = {};                          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          if ( $url eq '/' ) {  =head2 Database
122                  $json = {  
123                          couchdb => "Emulated on Frey",  L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction
124                          version => 0,  
125    =cut
126    
127            } elsif (
128                       $url =~ m{($regex_dbs)/$}
129                    # DELETE doesn't have trailing slash
130                    || $method eq 'DELETE' && $url =~ m{($regex_dbs)$}
131            ) {
132    
133                    my $database = $1;
134    
135                    my $dir = "$path/$database";
136    
137                    if ( $method eq 'GET' ) {
138                            $json = database_get( $database );
139                    } elsif ( $method eq 'DELETE' ) {
140                            if ( ! -e $dir ) {
141                                    $status = 404;
142                            } else {
143                                    remove_tree($dir);
144                                    if ( ! -d $dir ) {
145                                            ok;
146                                    } else {
147                                            $status = 500;
148                                    }
149                            }
150                    } elsif ( $method eq 'PUT' ) {
151                            if ( -e $dir ) {
152                                    $status = 412;
153                            } else {
154                                    make_path($dir);
155                                    if ( -e $path ) {
156                                            ok;
157                                            $status = 201;
158                                    } else {
159                                            $status = 500;
160                                    }
161                            }
162                    }
163    
164                    warn "## database $database $status ",dump( $json );
165    
166            } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
167                    my ($database,$id,$args) = ($1,$2,$3);
168    
169    =head2 Document
170    
171    L<http://wiki.apache.org/couchdb/HTTP_Document_API>
172    
173    =cut
174    
175                    my $arg;
176                    if ( $args ) {
177                            foreach my $a ( split(/[&;]/,$args) ) {
178                                    my ($n,$v) = split(/=/,$a);
179                                    $v =~ s{(["'])(.+)\1}{$2};
180                                    $arg->{$n} = $v;
181                            }
182                    }
183    
184                    warn "ERROR: path $path doesn't exist\n" unless -e $path;
185    
186                    my $p = "$path/$database/$id";
187                    warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";
188    
189    
190                    if ( $id =~ m{_all_docs(\w*)$} ) {
191    
192                            my $by = $1;
193                            my $offset = 0;
194                            my $startkey = delete $arg->{startkey};
195                            my $endkey   = delete $arg->{endkey};
196                            my $limit    = delete $arg->{limit};
197                            my $total_rows = 0;
198    
199                            my @docs = grep { length $_ } map {
200    
201                                    if ( $limit > 0 && $total_rows == $limit ) {
202                                            '';
203                                    } else {
204            
205                                            s{^$path/$database/}{};
206    
207                                            if ( defined $endkey && $_ gt $endkey ) {
208                                                    '';
209                                            } elsif ( $startkey ) {
210                                                    if ( $_ ge $startkey ) {
211                                                            $total_rows++;
212                                                            $_;
213                                                    } else {
214                                                            $offset++;
215                                                            '';
216                                                    }
217                                            } else {
218                                                    $total_rows++;
219                                                    $_;
220                                            }
221                                    }
222    
223                            } glob( "$path/$database/*" );
224    
225    
226                            warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
227    
228                            $json = {
229                                    total_rows =>  $total_rows,
230                                    offset => $offset,
231                                    rows => [],
232                            };
233    
234                            my $rows;
235                            my @ids;
236    
237                            foreach my $id ( @docs ) {
238                                    warn "++ $id\n" if $debug;
239                                    my $p = "$path/$database/$id";
240                                    my $data = eval { Storable::retrieve( $p ) };
241                                    if ( $@ ) {
242                                            warn "ERROR: $p | $@\n";
243                                            next;
244                                    }
245                                    push @ids, $id;
246                                    $rows->{$id} = {
247                                            id => $id,
248                                            key => $id,
249                                            value => {
250                                                    rev => file_rev $p,
251                                            }
252                                    };
253                            }
254    
255                            my $descending = delete $arg->{descending};
256                            my @sorted = sort @ids;
257    
258                            warn "creating rows in ", $descending ? "descending" : "", " order\n";
259    
260                            foreach my $id ( $descending ? reverse @sorted : @sorted ) {
261                                    warn ">> $id ", $descending ? 'desc' : 'asc', "\n" if $debug;
262                                    push @{ $json->{rows} }, $rows->{$id};
263                            }
264    
265                            $status = 200;
266    
267                    } elsif ( $method eq 'PUT' ) {
268            
269                            warn "## ",dump( $tx->req ) if $debug;
270    
271                            my $data = $tx->req->content->file->slurp;
272    
273                            my $db_path = "$path/$database";
274                            make_path $db_path unless -e $db_path;
275    
276                            Storable::store( from_json($data), $p );
277                            my $rev = file_rev $p;
278                            warn "store $p $rev size ", -s $p, " bytes | $data\n";
279    
280                            $status = 201; # Created
281                            $json = {
282                                    id => $id,
283                                    ok => JSON::true,
284                                    rev => $rev,
285                            };
286    
287                    } elsif ( $method eq 'GET' ) {
288                            if ( ! -e $p ) {
289                                    $status = 404;
290                            } else {
291                                    warn "retrive $p ", -s $p, " bytes\n";
292                                    $json = Storable::retrieve( $p );
293                                    if ( delete $arg->{revs_info} ) {
294                                            my $rev = file_rev $p;
295                                            $json->{_rev} = $rev;
296                                            $json->{_revs_info} = [
297                                                    { rev => $rev, status => 'available' }
298                                            ];
299                                    }
300                                    $status = 200;
301    
302                            }
303                    } elsif ( $method eq 'DELETE' ) {
304                            if ( -e $p ) {
305                                    unlink $p && ok || { $status = 500 };
306                            } else {
307                                    $status = 404;
308                            }
309                    } elsif ( $method eq 'POST' ) {
310                            $json = { total_rows => 0, offset => 0 };
311                            $status = 202; # FIXME implement real view server and return 200
312                    } else {
313                            $status = 501;
314                    }
315    
316                    if ( keys %$arg ) {
317                            warn "WARNING: arg left from $url = ",dump( $arg ),$/;
318                            $status = 501;
319                  }                  }
         } elsif ( $url eq '/_all_dbs' ) {  
                 $json = [ @all_dbs ];  
         } elsif ( $url =~ m{($regex_dbs)} ) {  
                 warn "# collecting docs from $path/$1/*\n";  
                 my @docs = glob "$path/$1/*";  
                 $json = {  
                         db_name => $1,  
                         doc_count => $#docs + 1,  
                         doc_del_count => 0,  
                         update_seq => 0,  
                         purge_seq => 0,  
                         capacity_running => JSON::false,  
                         disk_size => 0,  
                         instance_start_time => time(),  
                 };  
320    
                 warn "## calculating disk_size\n";  
                 $json->{disk_size} += -s "$path/$1/$_" foreach $docs;  
321          }          }
322    
323          $tx->res->code( 200 );          $json = { error => 'not_found', reason => 'Missing' } if $status == 404;
324          $tx->res->headers->content_type( 'text/json' );  
325          $tx->res->body( to_json $json );          if ( $method =~ m{(DELETE|PUT)} ) {
326                    $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs );
327            }
328    
329            $tx->res->code( $status );
330            $tx->res->headers->content_type( 'text/plain;charset=utf-8' );
331            my $body = to_json $json;
332            $tx->res->body( $body );
333            $tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' );
334            $tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" );
335    
336            print "$method $url $status\n$body\n";
337    
338            warn "## headers ", $tx->res->headers->to_string;
339    
340          return $tx;          return $tx;
341    
342  }  }
343    
344    sub database_get {
345            my ($db_name) = @_;
346            my $path = $config->{path};
347            warn "# collecting docs from $path/$db_name/*\n";
348            my @docs = glob "$path/$db_name/*";
349            my $json = {
350                    db_name => $db_name,
351                    doc_count => $#docs + 1,
352                    doc_del_count => 0,
353                    update_seq => 0,
354                    purge_seq => 0,
355                    capacity_running => JSON::false,
356                    disk_size => 0,
357                    instance_start_time => time(),
358            };
359    
360            warn "## calculating disk_size\n";
361            $json->{disk_size} += -s $_ foreach @docs;
362            $status = 200;
363            return $json;
364    }
365    
366  1;  1;
367    __END__
368    
369    =head1 SEE ALSO
370    
371    L<http://wiki.apache.org/couchdb/Reference>
372    
Legend:
Removed from v.1046  
changed lines
  Added in v.1059
  ViewVC Help
Powered by ViewVC 1.1.26