/[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 1047 by dpavlin, Wed Apr 22 23:38:10 2009 UTC revision 1051 by dpavlin, Thu Apr 23 19:35:26 2009 UTC
# Line 1  Line 1 
1  package Frey::CouchAPI;  package Frey::CouchAPI;
2    
3    =head1 DESCRIPTION
4    
5    This is REST wrapper using L<Mojo::Transaction> to implement Apache's CouchDB API
6    
7    =head1 Supported HTTP API
8    
9    =cut
10    
11    use warnings;
12    use strict;
13    
14  use JSON;  use JSON;
15  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
16  use URI::Escape;  use URI::Escape;
17  use File::Path qw(make_path remove_tree);  use File::Path qw(make_path remove_tree);
18  use Storable;  use Storable;
19    
20    our $VERSION = '0.1';
21    $VERSION .= ' on Frey ' . $Frey::VERSION;
22    
23    our $debug = $Frey::debug || 0;
24    
25  sub rewrite_urls {  sub rewrite_urls {
26          my ( $self, $tx ) = @_;          my ( $self, $tx ) = @_;
27          if ( $tx->req->url->path =~ m{/_utils/} ) {          if ( $tx->req->url->path =~ m{/_utils/} ) {
# Line 20  sub rewrite_urls { Line 36  sub rewrite_urls {
36          }          }
37  }  }
38    
39  my $path = '/data/webpac2/var/row';  our $config = {
40            path => '/data/webpac2/var/row',
41    };
42    
43    my $p = $config->{path};
44  my @all_dbs = map {  my @all_dbs = map {
45          s{^\Q$path\E/*}{};          s{^\Q$p\E/*}{};
46          $_;          $_;
47  } glob "$path/*/*";  } glob "$p/*/*";
48    
49  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
50    
51  our $json = {};  our $json = {};
52  our $stauts = 500;  our $status = 500;
53    
54  sub ok {  sub ok {
55          $json = { ok => JSON::true };          $json = { ok => JSON::true };
56          $status = 200;          $status = 200;
57  }  }
58    
59    
60  sub dispatch {  sub dispatch {
61          my ($self,$tx) = @_;          my ($self,$tx) = @_;
62    
63          my $url = $tx->req->url->to_string;          my $url = $tx->req->url->to_string;
64          $url = uri_unescape( $url );          $url = uri_unescape( $url );
65          my $method = $tx->req->method;          my $method = $tx->req->method;
66            
         warn "INFO: using Apache CouchDB emulation API\n";  
   
67          if ( $url eq '/' ) {          if ( $url eq '/' ) {
68                  $json = {                  $json = {
69                          couchdb => "Welcome",                          couchdb => "Welcome",
70                          version => "0-Frey",                          version => "CouchAPI $VERSION",
71                  }                  }
72          } elsif ( $url eq '/_all_dbs' ) {          } elsif ( $url eq '/_all_dbs' ) {
73                  $json = [ @all_dbs ];                  $json = [ @all_dbs ];
74                  $status = 200;                  $status = 200;
75            } elsif ( $url =~ m{^/_config/?(.+)} ) {
76    
77                    $json = { CouchAPI => $config };
78    
79                    if ( $method eq 'PUT' ) {
80    
81                            my $part = $1;
82                            warn "## part $part";
83    
84                            $part =~ s!^!->{'!;
85                            $part =~ s!/!'}->{'!;
86                            $part =~ s/$/'}/;
87    
88                            my $data = $tx->req->content->file->slurp;
89                            $data = JSON->new->allow_nonref->decode( $data );
90                            warn "## data ",dump( $data );
91                            # poor man's transaction :-)
92                            my $code = "\$json$part = \$data; \$config$part = \$data;";
93                            eval $code;
94                            if ( $@ ) {
95                                    warn "ERROR: $code -> $@";
96                                    $status = 500;
97                            } else {
98                                    $status = 200;
99                            }
100    
101    warn "json ",dump( $json ), " config ", dump( $config );
102    
103                    } elsif ( $method eq 'GET' ) {
104                            $status = 200;
105                    } else {
106                            $status = 501;
107                    }
108    
109          } elsif ( $url =~ m{($regex_dbs)/$} ) {          } elsif ( $url =~ m{($regex_dbs)/$} ) {
110    
111    =head2 Database
112    
113    L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction
114    
115    =cut
116    
117                  my $database = $1;                  my $database = $1;
118                  my $dir = "$path/$database";                  my $dir = "$config->{path}/$database";
119    
120                  if ( $method eq 'GET' ) {                  if ( $method eq 'GET' ) {
121                          $json = database_get( $database );                          $json = database_get( $database );
# Line 74  sub dispatch { Line 133  sub dispatch {
133                          }                          }
134                  }                  }
135    
136          } elsif ( $url =~ m{($regex_dbs)/(.+)$} ) {          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
137                  my ($database,$id) = ($1,$2);                  my ($database,$id,$args) = ($1,$2,$3);
138            
139    =head2 Document
140    
141    L<http://wiki.apache.org/couchdb/HTTP_Document_API>
142    
143    =cut
144    
145                    my $arg;
146                    if ( $args ) {
147                            foreach my $a ( split(/[&;]/,$args) ) {
148                                    my ($n,$v) = split(/=/,$a);
149                                    $v =~ s{(["'])(.+)\1}{$2};
150                                    $arg->{$n} = $v;
151                            }
152                    }
153    
154                    my $path = $config->{path};
155                    warn "ERROR: path $path doesn't exist\n" unless -e $path;
156    
157                  my $p = "$path/$database/$id";                  my $p = "$path/$database/$id";
158                  warn "## database: $database id: $id -> $p ";                  warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";
159    
                 if ( $id eq '_all_docs' ) {  
160    
161                          my @docs = map {                  if ( $id =~ m{_all_docs(\w+)?$} ) {
162    
163                            my $by = $1;
164                            my $offset = 0;
165                            my $startkey = delete $arg->{startkey};
166                            my $endkey   = delete $arg->{endkey};
167                            my $limit    = delete $arg->{limit};
168                            my $total_rows = 0;
169    
170                            my @docs = grep { length $_ } map {
171                                    return '' if defined $limit && $total_rows == $limit;
172            
173                                  s{^$path/$database/}{};                                  s{^$path/$database/}{};
174                                  $_;                                  return '' if defined $endkey && $_ gt $endkey;
175    
176                                    if ( $startkey ) {
177                                            if ( $_ ge $startkey ) {
178                                                    $total_rows++;
179                                                    $_;
180                                            } else {
181                                                    $offset++;
182                                                    return '';
183                                            }
184                                    } else {
185                                            $total_rows++;
186                                            $_;
187                                    }
188    
189                          } glob( "$path/$database/*" );                          } glob( "$path/$database/*" );
190    
191                          warn "## docs ", dump( @docs );                          warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
192    
193                          $json = {                          $json = {
194                                  total_rows =>  $#docs + 1,                                  total_rows =>  $total_rows,
195                                  offset => 0,                                  offset => $offset,
196                                  rows => [],                                  rows => [],
197                          };                          };
198    
199                            my $rows;
200                            my @ids;
201    
202                          foreach my $id ( @docs ) {                          foreach my $id ( @docs ) {
203                                  warn "++ $id\n";                                  warn "++ $id\n" if $debug;
204                                  my $p = "$path/$database/$id";                                  my $p = "$path/$database/$id";
205                                  my $data = Storable::retrieve( $p );                                  my $data = eval { Storable::retrieve( $p ) };
206                                  push @{ $json->{rows} }, {                                  if ( $@ ) {
207                                            warn "ERROR: $p | $@\n";
208                                            next;
209                                    }
210                                    push @ids, $id;
211                                    $rows->{$id} = {
212                                          id => $id,                                          id => $id,
213                                          key => $id,                                          key => $id,
214                                          value => {                                          value => {
# Line 108  sub dispatch { Line 217  sub dispatch {
217                                  };                                  };
218                          }                          }
219    
220                            my $descending = delete $arg->{descending};
221                            my @sorted = sort @ids;
222    
223                            warn "creating rows in ", $descending ? "descending" : "", " order\n";
224    
225                            foreach my $id ( $descending ? reverse @sorted : @sorted ) {
226                                    warn ">> $id ", $descending ? 'desc' : 'asc', "\n" if $debug;
227                                    push @{ $json->{rows} }, $rows->{$id};
228                            }
229    
230                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
231                    
232                          warn "## ",dump( $tx->req );                          warn "## ",dump( $tx->req ) if $debug;
233    
234                          my $data = $tx->req->content->file->slurp;                          my $data = $tx->req->content->file->slurp;
235    
236                          Storable::store( from_json($data), $p );                          Storable::store( from_json($data), $p );
237                          warn "store $p ", -s $p, " bytes: $data\n";                          warn "store $p ", -s $p, " bytes: $data\n";
238                  } elsif ( $method eq 'GET' ) {                  } elsif ( $method eq 'GET' ) {
239                          warn "retrive $p ", -s $p, " bytes\n";                          if ( ! -e $p ) {
240                          $json = Storable::retrieve( $p );                                  $status = 404;
241                            } else {
242                                    warn "retrive $p ", -s $p, " bytes\n";
243                                    $json = Storable::retrieve( $p );
244                            }
245                    } elsif ( $method eq 'DELETE' ) {
246                            if ( -e $p ) {
247                                    unlink $p || { $status = 501 };
248                            } else {
249                                    $status = 404;
250                            }
251                  } else {                  } else {
252                          $status = 501;                          $status = 501;
253                  }                  }
254    
255                    warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;
256    
257          }          }
258    
259          if ( $status >= 400 && $status < 500 && ! defined $json) {          if ( $status >= 400 && $status < 500 && ! defined $json) {
# Line 141  sub dispatch { Line 272  sub dispatch {
272    
273  sub database_get {  sub database_get {
274          my ($db_name) = @_;          my ($db_name) = @_;
275            my $path = $config->{path};
276          warn "# collecting docs from $path/$db_name/*\n";          warn "# collecting docs from $path/$db_name/*\n";
277          my @docs = glob "$path/$db_name/*";          my @docs = glob "$path/$db_name/*";
278          my $json = {          my $json = {
# Line 155  sub database_get { Line 287  sub database_get {
287          };          };
288    
289          warn "## calculating disk_size\n";          warn "## calculating disk_size\n";
290          $json->{disk_size} += -s "$path/$1/$_" foreach $docs;          $json->{disk_size} += -s $_ foreach @docs;
291          $status = 200;          $status = 200;
292          return $json;          return $json;
293  }  }
294    
295  1;  1;
296    __END__
297    
298    =head1 SEE ALSO
299    
300    L<http://wiki.apache.org/couchdb/Reference>
301    
Legend:
Removed from v.1047  
changed lines
  Added in v.1051
  ViewVC Help
Powered by ViewVC 1.1.26