/[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 1049 by dpavlin, Thu Apr 23 17:26:04 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;  use warnings;
12  use strict;  use strict;
13    
# Line 10  use File::Path qw(make_path remove_tree) Line 18  use File::Path qw(make_path remove_tree)
18  use Storable;  use Storable;
19    
20  our $VERSION = '0.1';  our $VERSION = '0.1';
21  $VERSION .= '-Frey-' . $Frey::VERSION;  $VERSION .= ' on Frey ' . $Frey::VERSION;
22    
23  our $debug = $Frey::debug || 0;  our $debug = $Frey::debug || 0;
24    
# Line 28  sub rewrite_urls { Line 36  sub rewrite_urls {
36          }          }
37  }  }
38    
39  my $path = '/data/webpac2/var/ds';  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    
# Line 44  sub ok { Line 56  sub ok {
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            
67          if ( $url eq '/' ) {          if ( $url eq '/' ) {
68                  $json = {                  $json = {
69                          couchdb => "Welcome",                          couchdb => "Welcome",
70                          version => $VERSION,                          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} ) {          } elsif ( $url =~ m{^/_config/?(.+)} ) {
76                  $json = {  
77                          couchdb => {                  $json = { CouchAPI => $config };
78                                  version => $VERSION,  
79                                  path => $path,                  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                  $status = 200;  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 91  sub dispatch { Line 136  sub dispatch {
136          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
137                  my ($database,$id,$args) = ($1,$2,$3);                  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;                  my $arg;
146                  if ( $args ) {                  if ( $args ) {
147                          foreach my $a ( split(/[&;]/,$args) ) {                          foreach my $a ( split(/[&;]/,$args) ) {
# Line 99  sub dispatch { Line 150  sub dispatch {
150                                  $arg->{$n} = $v;                                  $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 [$args]\n";                  warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";
159    
160    
161                  if ( $id =~ m{_all_docs(\w+)?$} ) {                  if ( $id =~ m{_all_docs(\w+)?$} ) {
# Line 109  sub dispatch { Line 163  sub dispatch {
163                          my $by = $1;                          my $by = $1;
164                          my $offset = 0;                          my $offset = 0;
165                          my $startkey = delete $arg->{startkey};                          my $startkey = delete $arg->{startkey};
166  warn "STARTKEY: $startkey\n";                          my $endkey   = delete $arg->{endkey};
167                            my $limit    = delete $arg->{limit};
168                          my $total_rows = 0;                          my $total_rows = 0;
169    
170                          my @docs = grep { length $_ } map {                          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 ) {                                  if ( $startkey ) {
177                                          if ( $_ >= $startkey ) {                                          if ( $_ ge $startkey ) {
178                                                  $total_rows++;                                                  $total_rows++;
179                                                  $_;                                                  $_;
180                                          } else {                                          } else {
181                                                  $offset++;                                                  $offset++;
182                                                    return '';
183                                          }                                          }
184                                  } else {                                  } else {
185                                          $total_rows++;                                          $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 =>  $total_rows,                                  total_rows =>  $total_rows,
# Line 159  warn "STARTKEY: $startkey\n"; Line 220  warn "STARTKEY: $startkey\n";
220                          my $descending = delete $arg->{descending};                          my $descending = delete $arg->{descending};
221                          my @sorted = sort @ids;                          my @sorted = sort @ids;
222    
223                            warn "creating rows in ", $descending ? "descending" : "", " order\n";
224    
225                          foreach my $id ( $descending ? reverse @sorted : @sorted ) {                          foreach my $id ( $descending ? reverse @sorted : @sorted ) {
226                                  warn ">> $id ", $descending ? 'desc' : 'asc', "\n";                                  warn ">> $id ", $descending ? 'desc' : 'asc', "\n" if $debug;
227                                  push @{ $json->{rows} }, $rows->{$id};                                  push @{ $json->{rows} }, $rows->{$id};
228                          }                          }
229    
# Line 209  warn "STARTKEY: $startkey\n"; Line 272  warn "STARTKEY: $startkey\n";
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 229  sub database_get { Line 293  sub database_get {
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.1049  
changed lines
  Added in v.1051
  ViewVC Help
Powered by ViewVC 1.1.26