/[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 1046 by dpavlin, Wed Apr 22 22:01:06 2009 UTC revision 1061 by dpavlin, Fri Apr 24 21:51:03 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.3';
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  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_\$\(\)\+\-/]+';
53    
54    our $json = {};
55    our $status;
56    
57    sub ok {
58            $json = { ok => JSON::true };
59            $status = 200;
60            warn "ok from ",join(' ',caller),$/;
61    }
62    
63    sub file_rev { (stat($_[0]))[9] } # mtime
64    
65  my $regex_dbs = join('|', @all_dbs);  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;
81            my $path = $config->{database}->{path};
82            
83            if ( $url eq '/' ) {
84                    $json = {
85                            couchdb => "Welcome",
86                            version => "CouchAPI $VERSION",
87                    };
88                    $status = 200;
89            } elsif ( $url eq '/_all_dbs' ) {
90                    $json = [
91                            map {
92                                    s{^\Q$path\E/*}{};
93                                    $_;
94                            } glob $path . $config->{database}->{name_glob}
95                    ];
96                    $status = 200;
97            } elsif ( $url =~ m{^/_config/?(.+)} ) {
98    
99                    $json = $config;
100    
101                    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                            warn "# config after $code is ",dump( $config ),$/;
120    
121                    } elsif ( $method eq 'GET' ) {
122                            $status = 200;
123                    } else {
124                            $status = 501;
125                    }
126    
127          warn "INFO: using Apache CouchDB emulation API $url\n";  =head2 Database
128    
129          warn "## tx = ",dump( $tx );  L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction
130    
131          my $json = {};  =cut
132    
133          if ( $url eq '/' ) {          } elsif (
134                  $json = {                     $url =~ m{($regex_dbs)/$}
135                          couchdb => "Emulated on Frey",                  # DELETE doesn't have trailing slash
136                          version => 0,                  || $method eq 'DELETE' && $url =~ m{($regex_dbs)$}
137            ) {
138    
139                    my $database = $1;
140    
141                    my $dir = "$path/$database";
142    
143                    if ( $method eq 'GET' ) {
144                            $json = database_get( $database );
145                    } elsif ( $method eq 'DELETE' ) {
146                            if ( ! -e $dir ) {
147                                    $status = 404;
148                            } else {
149                                    remove_tree($dir);
150                                    if ( ! -d $dir ) {
151                                            ok;
152                                    } else {
153                                            $status = 500;
154                                    }
155                            }
156                    } elsif ( $method eq 'PUT' ) {
157                            if ( -e $dir ) {
158                                    $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)/([^?]+)\??(.+)?$} ) {
173                    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;
182                    if ( $args ) {
183                            foreach my $a ( split(/[&;]/,$args) ) {
184                                    my ($n,$v) = split(/=/,$a);
185                                    $v =~ s{(["'])(.+)\1}{$2};
186                                    $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";
193                    warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";
194    
195    
196                    if ( $id =~ m{_all_docs(\w*)$} ) {
197    
198                            my $by = $1;
199                            my $offset = 0;
200                            my $startkey = delete $arg->{startkey};
201                            my $endkey   = delete $arg->{endkey};
202                            my $limit    = delete $arg->{limit};
203                            my $skip     = delete $arg->{skip};
204                            my $total_rows = 0;
205    
206                            my @docs = grep { length $_ } map {
207    
208                                    if ( $limit > 0 && $total_rows == $limit ) {
209                                            '';
210                                    } else {
211            
212                                            s{^$path/$database/}{};
213    
214                                            if ( defined $endkey && $_ gt $endkey ) {
215                                                    '';
216                                            } elsif ( $startkey ) {
217                                                    if ( $_ ge $startkey ) {
218                                                            $total_rows++;
219                                                            $_;
220                                                    } else {
221                                                            $offset++;
222                                                            '';
223                                                    }
224                                            } else {
225                                                    $total_rows++;
226                                                    $_;
227                                            }
228                                    }
229    
230                            } glob( "$path/$database/*" );
231    
232                            $offset += $skip if $skip;
233    
234                            warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
235    
236                            $json = {
237                                    total_rows =>  $total_rows,
238                                    offset => $offset,
239                                    rows => [],
240                            };
241    
242                            my $rows;
243                            my @ids;
244    
245                            foreach my $id ( @docs ) {
246                                    warn "++ $id\n" if $debug;
247                                    my $p = "$path/$database/$id";
248                                    my $data = eval { Storable::retrieve( $p ) };
249                                    if ( $@ ) {
250                                            warn "ERROR: $p | $@\n";
251                                            next;
252                                    }
253                                    push @ids, $id;
254                                    $rows->{$id} = {
255                                            id => $id,
256                                            key => $id,
257                                            value => {
258                                                    rev => file_rev $p,
259                                            }
260                                    };
261                            }
262    
263                            my $descending = delete $arg->{descending};
264                            my @sorted = sort @ids;
265    
266                            warn "creating rows in ", $descending ? "descending" : "", " order\n";
267    
268                            foreach my $id ( $descending ? reverse @sorted : @sorted ) {
269                                    warn ">> $id ", $descending ? 'desc' : 'asc', "\n" if $debug;
270                                    push @{ $json->{rows} }, $rows->{$id};
271                            }
272    
273                            $status = 200;
274    
275                    } elsif ( $method eq 'PUT' ) {
276            
277                            warn "## ",dump( $tx->req ) if $debug;
278    
279                            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 );
285                            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' ) {
296                            if ( ! -e $p ) {
297                                    $status = 404;
298                            } else {
299                                    warn "retrive $p ", -s $p, " bytes\n";
300                                    $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' ) {
312                            if ( -e $p ) {
313                                    unlink $p && ok || { $status = 500 };
314                            } else {
315                                    $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 {
325                            $status = 501;
326                    }
327    
328                    if ( keys %$arg ) {
329                            warn "WARNING: arg left from $url = ",dump( $arg ),$/;
330                            $status = 501;
331                  }                  }
         } 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(),  
                 };  
332    
                 warn "## calculating disk_size\n";  
                 $json->{disk_size} += -s "$path/$1/$_" foreach $docs;  
333          }          }
334    
335          $tx->res->code( 200 );          $json = { error => 'not_found', reason => 'Missing' } if $status == 404;
336          $tx->res->headers->content_type( 'text/json' );  
337          $tx->res->body( to_json $json );          if ( $method =~ m{(DELETE|PUT)} ) {
338                    $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs );
339            }
340    
341            $tx->res->code( $status );
342            $tx->res->headers->content_type( 'text/plain;charset=utf-8' );
343            my $body = to_json $json;
344            $tx->res->body( $body );
345            $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  }  }
355    
356    sub database_get {
357            my ($db_name) = @_;
358            my $path = $config->{database}->{path} || die;
359            warn "# collecting docs from $path/$db_name/*\n";
360            my @docs = glob "$path/$db_name/*";
361            my $json = {
362                    db_name => $db_name,
363                    doc_count => $#docs + 1,
364                    doc_del_count => 0,
365                    update_seq => 0,
366                    purge_seq => 0,
367                    capacity_running => JSON::false,
368                    disk_size => 0,
369                    instance_start_time => time(),
370            };
371    
372            warn "## calculating disk_size\n";
373            $json->{disk_size} += -s $_ foreach @docs;
374            $status = 200;
375            return $json;
376    }
377    
378  1;  1;
379    __END__
380    
381    =head1 SEE ALSO
382    
383    L<http://wiki.apache.org/couchdb/Reference>
384    
Legend:
Removed from v.1046  
changed lines
  Added in v.1061
  ViewVC Help
Powered by ViewVC 1.1.26