/[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 1053 by dpavlin, Thu Apr 23 20:24:48 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 = '[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\n";
64    }
65    
 my $regex_dbs = join('|', @all_dbs);  
66    
67  sub dispatch {  sub dispatch {
68          my ($self,$tx) = @_;          my ($self,$tx) = @_;
69    
70            $status = 500; # Internal Error
71    
72          my $url = $tx->req->url->to_string;          my $url = $tx->req->url->to_string;
73          $url = uri_unescape( $url );          $url = uri_unescape( $url );
74            my $method = $tx->req->method;
75            
76            if ( $url eq '/' ) {
77                    $json = {
78                            couchdb => "Welcome",
79                            version => "CouchAPI $VERSION",
80                    };
81                    $status = 200;
82            } elsif ( $url eq '/_all_dbs' ) {
83                    $json = [ @all_dbs ];
84                    $status = 200;
85            } elsif ( $url =~ m{^/_config/?(.+)} ) {
86    
87          warn "INFO: using Apache CouchDB emulation API $url\n";                  $json = { CouchAPI => $config };
88    
89          warn "## tx = ",dump( $tx );                  if ( $method eq 'PUT' ) {
90    
91          my $json = {};                          my $part = $1;
92                            warn "## part $part";
93    
94                            $part =~ s!^!->{'!;
95                            $part =~ s!/!'}->{'!;
96                            $part =~ s/$/'}/;
97    
98                            my $data = $tx->req->content->file->slurp;
99                            $data = JSON->new->allow_nonref->decode( $data );
100                            warn "## data ",dump( $data );
101                            # poor man's transaction :-)
102                            my $code = "\$json$part = \$data; \$config$part = \$data;";
103                            eval $code;
104                            if ( $@ ) {
105                                    warn "ERROR: $code -> $@";
106                                    $status = 500;
107                            } else {
108                                    $status = 200;
109                            }
110    
111    warn "json ",dump( $json ), " config ", dump( $config );
112    
113                    } elsif ( $method eq 'GET' ) {
114                            $status = 200;
115                    } else {
116                            $status = 501;
117                    }
118    
119          if ( $url eq '/' ) {          } elsif ( $url =~ m{($regex_dbs)/$} ) {
120                  $json = {  
121                          couchdb => "Emulated on Frey",  =head2 Database
122                          version => 0,  
123    L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction
124    
125    =cut
126    
127                    my $database = $1;
128                    my $dir = "$config->{path}/$database";
129    
130                    if ( $method eq 'GET' ) {
131                            $json = database_get( $database );
132                    } elsif ( $method eq 'DELETE' ) {
133                            if ( ! -e $dir ) {
134                                    $status = 404;
135                            } else {
136                                    remove_tree($dir) && ok || { $status = 500 };
137                            }
138                    } elsif ( $method eq 'PUT' ) {
139                            if ( ! -e $dir ) {
140                                    make_path($dir) && ok && warn "created $dir" || { $status = 500 };
141                            } else {
142                                    $status = 412;
143                            }
144                  }                  }
         } 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(),  
                 };  
145    
146                  warn "## calculating disk_size\n";          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
147                  $json->{disk_size} += -s "$path/$1/$_" foreach $docs;                  my ($database,$id,$args) = ($1,$2,$3);
148    
149    =head2 Document
150    
151    L<http://wiki.apache.org/couchdb/HTTP_Document_API>
152    
153    =cut
154    
155                    my $arg;
156                    if ( $args ) {
157                            foreach my $a ( split(/[&;]/,$args) ) {
158                                    my ($n,$v) = split(/=/,$a);
159                                    $v =~ s{(["'])(.+)\1}{$2};
160                                    $arg->{$n} = $v;
161                            }
162                    }
163    
164                    my $path = $config->{path};
165                    warn "ERROR: path $path doesn't exist\n" unless -e $path;
166    
167                    my $p = "$path/$database/$id";
168                    warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";
169    
170    
171                    if ( $id =~ m{_all_docs(\w+)?$} ) {
172    
173                            my $by = $1;
174                            my $offset = 0;
175                            my $startkey = delete $arg->{startkey};
176                            my $endkey   = delete $arg->{endkey};
177                            my $limit    = delete $arg->{limit};
178                            my $total_rows = 0;
179    
180                            my @docs = grep { length $_ } map {
181                                    return '' if defined $limit && $total_rows == $limit;
182            
183                                    s{^$path/$database/}{};
184                                    return '' if defined $endkey && $_ gt $endkey;
185    
186                                    if ( $startkey ) {
187                                            if ( $_ ge $startkey ) {
188                                                    $total_rows++;
189                                                    $_;
190                                            } else {
191                                                    $offset++;
192                                                    return '';
193                                            }
194                                    } else {
195                                            $total_rows++;
196                                            $_;
197                                    }
198    
199                            } glob( "$path/$database/*" );
200    
201                            warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
202    
203                            $json = {
204                                    total_rows =>  $total_rows,
205                                    offset => $offset,
206                                    rows => [],
207                            };
208    
209                            my $rows;
210                            my @ids;
211    
212                            foreach my $id ( @docs ) {
213                                    warn "++ $id\n" if $debug;
214                                    my $p = "$path/$database/$id";
215                                    my $data = eval { Storable::retrieve( $p ) };
216                                    if ( $@ ) {
217                                            warn "ERROR: $p | $@\n";
218                                            next;
219                                    }
220                                    push @ids, $id;
221                                    $rows->{$id} = {
222                                            id => $id,
223                                            key => $id,
224                                            value => {
225                                                    rev => (stat($p))[9], # mtime
226                                            }
227                                    };
228                            }
229    
230                            my $descending = delete $arg->{descending};
231                            my @sorted = sort @ids;
232    
233                            warn "creating rows in ", $descending ? "descending" : "", " order\n";
234    
235                            foreach my $id ( $descending ? reverse @sorted : @sorted ) {
236                                    warn ">> $id ", $descending ? 'desc' : 'asc', "\n" if $debug;
237                                    push @{ $json->{rows} }, $rows->{$id};
238                            }
239    
240                    } elsif ( $method eq 'PUT' ) {
241            
242                            warn "## ",dump( $tx->req ) if $debug;
243    
244                            my $data = $tx->req->content->file->slurp;
245    
246                            Storable::store( from_json($data), $p );
247                            warn "store $p ", -s $p, " bytes: $data\n";
248                            $status = 201; # Created
249            
250                    } elsif ( $method eq 'GET' ) {
251                            if ( ! -e $p ) {
252                                    $status = 404;
253                            } else {
254                                    warn "retrive $p ", -s $p, " bytes\n";
255                                    $json = Storable::retrieve( $p );
256                            }
257                    } elsif ( $method eq 'DELETE' ) {
258                            if ( -e $p ) {
259                                    unlink $p || { $status = 500 };
260                            } else {
261                                    $status = 404;
262                            }
263                    } else {
264                            $status = 501;
265                    }
266    
267                    warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;
268    
269          }          }
270    
271          $tx->res->code( 200 );          $json = { error => 'not_found', reason => 'Missing' } if $status == 404;
272          $tx->res->headers->content_type( 'text/json' );  
273          $tx->res->body( to_json $json );          if ( $method =~ m{(DELETE|PUT)} ) {
274                    $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs );
275            }
276    
277            $tx->res->code( $status );
278            $tx->res->headers->content_type( 'text/plain;charset=utf-8' );
279            my $body = to_json $json;
280            $tx->res->body( $body );
281            $tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' );
282            $tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" );
283    
284            warn "INFO CouchDB API $method $url $status\n$body\n";
285    
286            warn "## headers ", $tx->res->headers->to_string;
287    
288          return $tx;          return $tx;
289    
290  }  }
291    
292    sub database_get {
293            my ($db_name) = @_;
294            my $path = $config->{path};
295            warn "# collecting docs from $path/$db_name/*\n";
296            my @docs = glob "$path/$db_name/*";
297            my $json = {
298                    db_name => $db_name,
299                    doc_count => $#docs + 1,
300                    doc_del_count => 0,
301                    update_seq => 0,
302                    purge_seq => 0,
303                    capacity_running => JSON::false,
304                    disk_size => 0,
305                    instance_start_time => time(),
306            };
307    
308            warn "## calculating disk_size\n";
309            $json->{disk_size} += -s $_ foreach @docs;
310            $status = 200;
311            return $json;
312    }
313    
314  1;  1;
315    __END__
316    
317    =head1 SEE ALSO
318    
319    L<http://wiki.apache.org/couchdb/Reference>
320    
Legend:
Removed from v.1046  
changed lines
  Added in v.1053
  ViewVC Help
Powered by ViewVC 1.1.26