/[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 1075 by dpavlin, Fri May 15 20:43:17 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    You can access it using normal C</_utils/> URI, just like on real CouchDB and
8    it will bring up partially functional Futon interface against this module.
9    
10    L<Mojo::URL>
11    
12    L<Mojo::Transaction>
13    
14    
15    =head1 Supported HTTP API
16    
17    =cut
18    
19    use warnings;
20    use strict;
21    
22  use JSON;  use JSON;
23  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
24  use URI::Escape;  use URI::Escape;
25    use File::Path;
26    use Storable;
27    
28    our $VERSION = '0.3';
29    $VERSION .= " (Frey $Frey::VERSION)" if $Frey::VERSION;
30    
31    our $debug = $Frey::debug || 0;
32    
33  sub rewrite_urls {  sub rewrite_urls {
34          my ( $self, $tx ) = @_;          my ( $self, $tx ) = @_;
# Line 18  sub rewrite_urls { Line 44  sub rewrite_urls {
44          }          }
45  }  }
46    
47  my $path = '/data/webpac2/var/row';  our $config = {
48  my @all_dbs = map {          database => {
49          s{^\Q$path\E/*}{};                  path => '/data/webpac2/var/row',
50          $_;                  name_glob => '/*/*',
51  } glob "$path/*/*";          }
52    };
53    
54    my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
55    
56    our $json = {};
57    our $status;
58    
59    sub ok {
60            $json = { ok => JSON::true };
61            $status = 200;
62            warn "ok from ",join(' ',caller),$/;
63    }
64    
65    sub file_rev { (stat($_[0]))[9] } # mtime
66    
67  my $regex_dbs = join('|', @all_dbs);  sub data_from_tx {
68            my $tx = shift;
69            my $data = $tx->req->content->file->slurp;
70            $data = JSON->new->allow_nonref->decode( $data );
71            warn "## data ",dump( $data );
72            return $data;
73    }
74    
75  sub dispatch {  sub dispatch {
76          my ($self,$tx) = @_;          my ($self,$tx) = @_;
77    
78            $status = 500; # Internal Error
79    
80          my $url = $tx->req->url->to_string;          my $url = $tx->req->url->to_string;
81          $url = uri_unescape( $url );          $url = uri_unescape( $url );
82            my $method = $tx->req->method;
83            my $path = $config->{database}->{path};
84            
85            if ( $url eq '/' ) {
86                    $json = {
87                            couchdb => "Welcome",
88                            version => "CouchAPI $VERSION",
89                    };
90                    $status = 200;
91            } elsif ( $url eq '/_all_dbs' ) {
92                    $json = [
93                            map {
94                                    s{^\Q$path\E/*}{};
95                                    $_;
96                            } glob $path . $config->{database}->{name_glob}
97                    ];
98                    $status = 200;
99            } elsif ( $url =~ m{^/_config/?(.+)} ) {
100    
101                    $json = $config;
102    
103                    if ( $method eq 'PUT' ) {
104    
105                            my $part = $1;
106                            my $data = data_from_tx( $tx );
107                            warn "## part $part = $data\n";
108    
109                            $part =~ s!/!'}->{'!;
110    
111                            # poor man's transaction :-)
112                            my $code = "\$config->{'$part'} = \$data;";
113                            eval $code;
114                            if ( $@ ) {
115                                    warn "ERROR: $code -> $@";
116                                    $status = 500;
117                            } else {
118                                    $status = 200;
119                            }
120    
121                            warn "# config after $code is ",dump( $config ),$/;
122    
123                    } elsif ( $method eq 'GET' ) {
124                            $status = 200;
125                    } else {
126                            $status = 501;
127                    }
128    
129          warn "INFO: using Apache CouchDB emulation API $url\n";  =head2 Database
130    
131          warn "## tx = ",dump( $tx );  L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction
132    
133          my $json = {};  =cut
134    
135          if ( $url eq '/' ) {          } elsif (
136                  $json = {                     $url =~ m{($regex_dbs)/$}
137                          couchdb => "Emulated on Frey",                  # DELETE doesn't have trailing slash
138                          version => 0,                  || $method eq 'DELETE' && $url =~ m{($regex_dbs)$}
139            ) {
140    
141                    my $database = $1;
142    
143                    my $dir = "$path/$database";
144    
145                    if ( $method eq 'GET' ) {
146                            $json = database_get( $database );
147                    } elsif ( $method eq 'DELETE' ) {
148                            if ( ! -e $dir ) {
149                                    $status = 404;
150                            } else {
151                                    rmtree($dir);
152                                    if ( ! -d $dir ) {
153                                            ok;
154                                    } else {
155                                            $status = 500;
156                                    }
157                            }
158                    } elsif ( $method eq 'PUT' ) {
159                            if ( -e $dir ) {
160                                    $status = 412;
161                            } else {
162                                    mkpath($dir);
163                                    if ( -e $path ) {
164                                            ok;
165                                            $status = 201;
166                                    } else {
167                                            $status = 500;
168                                    }
169                            }
170                    }
171    
172                    warn "## database $database $status ",dump( $json );
173    
174            } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
175                    my ($database,$id,$args) = ($1,$2,$3);
176    
177    =head2 Document
178    
179    L<http://wiki.apache.org/couchdb/HTTP_Document_API>
180    
181    =cut
182    
183                    my $arg;
184                    if ( $args ) {
185                            foreach my $a ( split(/[&;]/,$args) ) {
186                                    my ($n,$v) = split(/=/,$a);
187                                    $v =~ s{(["'])(.+)\1}{$2};
188                                    $arg->{$n} = $v;
189                            }
190                    }
191    
192                    warn "ERROR: path $path doesn't exist\n" unless -e $path;
193    
194                    my $p = "$path/$database/$id";
195                    warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";
196    
197    
198                    if ( $id =~ m{_all_docs(\w*)$} ) {
199    
200                            my $by = $1;
201                            my $offset = 0;
202                            my $startkey = delete $arg->{startkey};
203                               $startkey ||= delete $arg->{startkey_docid}; # XXX key == id
204                            my $endkey   = delete $arg->{endkey};
205                            my $limit    = delete $arg->{limit};
206                            my $skip     = delete $arg->{skip};
207                            my $total_rows = 0;
208                            my $collected_rows = 0;
209    
210                            my @docs = grep { length $_ } map {
211    
212                                    $total_rows++;
213            
214                                    if ( $limit > 0 && $collected_rows == $limit ) {
215                                            '';
216                                    } else {
217            
218                                            s{^$path/$database/}{};
219    
220                                            if ( defined $endkey && $_ gt $endkey ) {
221                                                    '';
222                                            } elsif ( $startkey ) {
223                                                    if ( $_ ge $startkey ) {
224                                                            $collected_rows++;
225                                                            $_;
226                                                    } else {
227                                                            $offset++;
228                                                            '';
229                                                    }
230                                            } else {
231                                                    $collected_rows++;
232                                                    $_;
233                                            }
234                                    }
235    
236                            } glob( "$path/$database/*" );
237    
238                            $offset += $skip if $skip;
239    
240                            warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
241    
242                            $json = {
243                                    total_rows =>  $total_rows,
244                                    offset => $offset,
245                                    rows => [],
246                            };
247    
248                            my $rows;
249                            my @ids;
250    
251                            foreach my $id ( @docs ) {
252                                    warn "++ $id\n" if $debug;
253                                    my $p = "$path/$database/$id";
254                                    my $data = eval { Storable::retrieve( $p ) };
255                                    if ( $@ ) {
256                                            warn "ERROR: $p | $@\n";
257                                            next;
258                                    }
259                                    push @ids, $id;
260                                    $rows->{$id} = {
261                                            id => $id,
262                                            key => $id,
263                                            value => {
264                                                    rev => file_rev $p,
265                                            }
266                                    };
267                            }
268    
269                            my $descending = delete $arg->{descending};
270                            my @sorted = sort @ids;
271    
272                            warn "creating rows in ", $descending ? "descending" : "", " order\n";
273    
274                            foreach my $id ( $descending ? reverse @sorted : @sorted ) {
275                                    warn ">> $id ", $descending ? 'desc' : 'asc', "\n" if $debug;
276                                    push @{ $json->{rows} }, $rows->{$id};
277                            }
278    
279                            $status = 200;
280    
281                    } elsif ( $method eq 'PUT' ) {
282            
283                            warn "## ",dump( $tx->req ) if $debug;
284    
285                            my $data = $tx->req->content->file->slurp;
286    
287                            my $db_path = "$path/$database";
288                            make_path $db_path unless -e $db_path;
289    
290                            Storable::store( from_json($data), $p );
291                            my $rev = file_rev $p;
292                            warn "store $p $rev size ", -s $p, " bytes | $data\n";
293    
294                            $status = 201; # Created
295                            $json = {
296                                    id => $id,
297                                    ok => JSON::true,
298                                    rev => $rev,
299                            };
300    
301                    } elsif ( $method eq 'GET' ) {
302                            if ( ! -e $p ) {
303                                    $status = 404;
304                            } else {
305                                    warn "retrive $p ", -s $p, " bytes\n";
306                                    $json = Storable::retrieve( $p );
307                                    if ( delete $arg->{revs_info} ) {
308                                            my $rev = file_rev $p;
309                                            $json->{_rev} = $rev;
310                                            $json->{_revs_info} = [
311                                                    { rev => $rev, status => 'available' }
312                                            ];
313                                    }
314                                    $status = 200;
315    
316                            }
317                    } elsif ( $method eq 'DELETE' ) {
318                            if ( -e $p ) {
319                                    unlink $p && ok || { $status = 500 };
320                            } else {
321                                    $status = 404;
322                            }
323                    } elsif ( $method eq 'POST' ) {
324                            my $data = data_from_tx( $tx );
325    
326                            # FIXME implement real view server and return 200
327                            $json = { total_rows => 0, offset => 0 };
328                            $status = 202;
329    
330                    } else {
331                            $status = 501;
332                    }
333    
334                    if ( keys %$arg ) {
335                            warn "WARNING: arg left from $url = ",dump( $arg ),$/;
336                            $status = 501;
337                  }                  }
         } 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(),  
                 };  
338    
                 warn "## calculating disk_size\n";  
                 $json->{disk_size} += -s "$path/$1/$_" foreach $docs;  
339          }          }
340    
341          $tx->res->code( 200 );          $json = { error => 'not_found', reason => 'Missing' } if $status == 404;
342          $tx->res->headers->content_type( 'text/json' );  
343          $tx->res->body( to_json $json );          if ( $method =~ m{(DELETE|PUT)} ) {
344                    $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs );
345            }
346    
347            $tx->res->code( $status );
348            $tx->res->headers->content_type( 'text/plain;charset=utf-8' );
349            my $body = to_json $json;
350            $tx->res->body( $body );
351            $tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' );
352            $tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" );
353    
354            print "$method $url $status\n$body\n";
355    
356            warn "## headers ", $tx->res->headers->to_string;
357    
358          return $tx;          return $tx;
359    
360  }  }
361    
362    sub database_get {
363            my ($db_name) = @_;
364            my $path = $config->{database}->{path} || die;
365            warn "# collecting docs from $path/$db_name/*\n";
366            my @docs = glob "$path/$db_name/*";
367            my $json = {
368                    db_name => $db_name,
369                    doc_count => $#docs + 1,
370                    doc_del_count => 0,
371                    update_seq => 0,
372                    purge_seq => 0,
373                    capacity_running => JSON::false,
374                    disk_size => 0,
375                    instance_start_time => time(),
376            };
377    
378            warn "## calculating disk_size\n";
379            $json->{disk_size} += -s $_ foreach @docs;
380            $status = 200;
381            return $json;
382    }
383    
384  1;  1;
385    __END__
386    
387    =head1 SEE ALSO
388    
389    L<http://wiki.apache.org/couchdb/Reference>
390    
Legend:
Removed from v.1046  
changed lines
  Added in v.1075
  ViewVC Help
Powered by ViewVC 1.1.26