/[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 1047 by dpavlin, Wed Apr 22 23:38:10 2009 UTC revision 1050 by dpavlin, Thu Apr 23 18:45:42 2009 UTC
# Line 1  Line 1 
1  package Frey::CouchAPI;  package Frey::CouchAPI;
2    
3    use warnings;
4    use strict;
5    
6  use JSON;  use JSON;
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8  use URI::Escape;  use URI::Escape;
9  use File::Path qw(make_path remove_tree);  use File::Path qw(make_path remove_tree);
10  use Storable;  use Storable;
11    
12    our $VERSION = '0.1';
13    $VERSION .= ' on Frey ' . $Frey::VERSION;
14    
15    our $debug = $Frey::debug || 0;
16    
17  sub rewrite_urls {  sub rewrite_urls {
18          my ( $self, $tx ) = @_;          my ( $self, $tx ) = @_;
19          if ( $tx->req->url->path =~ m{/_utils/} ) {          if ( $tx->req->url->path =~ m{/_utils/} ) {
# Line 20  sub rewrite_urls { Line 28  sub rewrite_urls {
28          }          }
29  }  }
30    
31  my $path = '/data/webpac2/var/row';  our $config = {
32            path => '/data/webpac2/var/row',
33    };
34    
35    my $p = $config->{path};
36  my @all_dbs = map {  my @all_dbs = map {
37          s{^\Q$path\E/*}{};          s{^\Q$p\E/*}{};
38          $_;          $_;
39  } glob "$path/*/*";  } glob "$p/*/*";
40    
41  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
42    
43  our $json = {};  our $json = {};
44  our $stauts = 500;  our $status = 500;
45    
46  sub ok {  sub ok {
47          $json = { ok => JSON::true };          $json = { ok => JSON::true };
48          $status = 200;          $status = 200;
49  }  }
50    
51    
52  sub dispatch {  sub dispatch {
53          my ($self,$tx) = @_;          my ($self,$tx) = @_;
54    
55          my $url = $tx->req->url->to_string;          my $url = $tx->req->url->to_string;
56          $url = uri_unescape( $url );          $url = uri_unescape( $url );
57          my $method = $tx->req->method;          my $method = $tx->req->method;
58            
         warn "INFO: using Apache CouchDB emulation API\n";  
   
59          if ( $url eq '/' ) {          if ( $url eq '/' ) {
60                  $json = {                  $json = {
61                          couchdb => "Welcome",                          couchdb => "Welcome",
62                          version => "0-Frey",                          version => "CouchAPI $VERSION",
63                  }                  }
64          } elsif ( $url eq '/_all_dbs' ) {          } elsif ( $url eq '/_all_dbs' ) {
65                  $json = [ @all_dbs ];                  $json = [ @all_dbs ];
66                  $status = 200;                  $status = 200;
67            } elsif ( $url =~ m{^/_config/?(.+)} ) {
68    
69                    $json = { CouchAPI => $config };
70    
71                    if ( $method eq 'PUT' ) {
72    
73                            my $part = $1;
74                            warn "## part $part";
75    
76                            $part =~ s!^!->{'!;
77                            $part =~ s!/!'}->{'!;
78                            $part =~ s/$/'}/;
79    
80                            my $data = $tx->req->content->file->slurp;
81                            $data = JSON->new->allow_nonref->decode( $data );
82                            warn "## data ",dump( $data );
83                            # poor man's transaction :-)
84                            my $code = "\$json$part = \$data; \$config$part = \$data;";
85                            eval $code;
86                            if ( $@ ) {
87                                    warn "ERROR: $code -> $@";
88                                    $status = 500;
89                            } else {
90                                    $status = 200;
91                            }
92    
93    warn "json ",dump( $json ), " config ", dump( $config );
94    
95                    } elsif ( $method eq 'GET' ) {
96                            $status = 200;
97                    } else {
98                            $status = 501;
99                    }
100    
101          } elsif ( $url =~ m{($regex_dbs)/$} ) {          } elsif ( $url =~ m{($regex_dbs)/$} ) {
102    
103                  my $database = $1;                  my $database = $1;
104                  my $dir = "$path/$database";                  my $dir = "$config->{path}/$database";
105    
106                  if ( $method eq 'GET' ) {                  if ( $method eq 'GET' ) {
107                          $json = database_get( $database );                          $json = database_get( $database );
# Line 74  sub dispatch { Line 119  sub dispatch {
119                          }                          }
120                  }                  }
121    
122          } elsif ( $url =~ m{($regex_dbs)/(.+)$} ) {          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
123                  my ($database,$id) = ($1,$2);                  my ($database,$id,$args) = ($1,$2,$3);
124            
125                    my $arg;
126                    if ( $args ) {
127                            foreach my $a ( split(/[&;]/,$args) ) {
128                                    my ($n,$v) = split(/=/,$a);
129                                    $v =~ s{(["'])(.+)\1}{$2};
130                                    $arg->{$n} = $v;
131                            }
132                    }
133    
134                    my $path = $config->{path};
135                    warn "ERROR: path $path doesn't exist\n" unless -e $path;
136    
137                  my $p = "$path/$database/$id";                  my $p = "$path/$database/$id";
138                  warn "## database: $database id: $id -> $p ";                  warn "## database: $database id: $id -> $p [$args]\n";
139    
                 if ( $id eq '_all_docs' ) {  
140    
141                          my @docs = map {                  if ( $id =~ m{_all_docs(\w+)?$} ) {
142    
143                            my $by = $1;
144                            my $offset = 0;
145                            my $startkey = delete $arg->{startkey};
146    warn "STARTKEY: $startkey\n";
147                            my $total_rows = 0;
148    
149                            my @docs = grep { length $_ } map {
150                                  s{^$path/$database/}{};                                  s{^$path/$database/}{};
151                                  $_;                                  if ( $startkey ) {
152                                            if ( $_ >= $startkey ) {
153                                                    $total_rows++;
154                                                    $_;
155                                            } else {
156                                                    $offset++;
157                                            }
158                                    } else {
159                                            $total_rows++;
160                                            $_;
161                                    }
162                          } glob( "$path/$database/*" );                          } glob( "$path/$database/*" );
163    
164                          warn "## docs ", dump( @docs );                          warn "## docs ", dump( @docs ) if $debug;
165    
166                          $json = {                          $json = {
167                                  total_rows =>  $#docs + 1,                                  total_rows =>  $total_rows,
168                                  offset => 0,                                  offset => $offset,
169                                  rows => [],                                  rows => [],
170                          };                          };
171    
172                            my $rows;
173                            my @ids;
174    
175                          foreach my $id ( @docs ) {                          foreach my $id ( @docs ) {
176                                  warn "++ $id\n";                                  warn "++ $id\n" if $debug;
177                                  my $p = "$path/$database/$id";                                  my $p = "$path/$database/$id";
178                                  my $data = Storable::retrieve( $p );                                  my $data = eval { Storable::retrieve( $p ) };
179                                  push @{ $json->{rows} }, {                                  if ( $@ ) {
180                                            warn "ERROR: $p | $@\n";
181                                            next;
182                                    }
183                                    push @ids, $id;
184                                    $rows->{$id} = {
185                                          id => $id,                                          id => $id,
186                                          key => $id,                                          key => $id,
187                                          value => {                                          value => {
# Line 108  sub dispatch { Line 190  sub dispatch {
190                                  };                                  };
191                          }                          }
192    
193                            my $descending = delete $arg->{descending};
194                            my @sorted = sort @ids;
195    
196                            warn "creating rows in ", $descending ? "descending" : "", " order\n";
197    
198                            foreach my $id ( $descending ? reverse @sorted : @sorted ) {
199                                    warn ">> $id ", $descending ? 'desc' : 'asc', "\n" if $debug;
200                                    push @{ $json->{rows} }, $rows->{$id};
201                            }
202    
203                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
204                    
205                          warn "## ",dump( $tx->req );                          warn "## ",dump( $tx->req ) if $debug;
206    
207                          my $data = $tx->req->content->file->slurp;                          my $data = $tx->req->content->file->slurp;
208    
209                          Storable::store( from_json($data), $p );                          Storable::store( from_json($data), $p );
210                          warn "store $p ", -s $p, " bytes: $data\n";                          warn "store $p ", -s $p, " bytes: $data\n";
211                  } elsif ( $method eq 'GET' ) {                  } elsif ( $method eq 'GET' ) {
212                          warn "retrive $p ", -s $p, " bytes\n";                          if ( ! -e $p ) {
213                          $json = Storable::retrieve( $p );                                  $status = 404;
214                            } else {
215                                    warn "retrive $p ", -s $p, " bytes\n";
216                                    $json = Storable::retrieve( $p );
217                            }
218                    } elsif ( $method eq 'DELETE' ) {
219                            if ( -e $p ) {
220                                    unlink $p || { $status = 501 };
221                            } else {
222                                    $status = 404;
223                            }
224                  } else {                  } else {
225                          $status = 501;                          $status = 501;
226                  }                  }
227    
228                    warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;
229    
230          }          }
231    
232          if ( $status >= 400 && $status < 500 && ! defined $json) {          if ( $status >= 400 && $status < 500 && ! defined $json) {
# Line 141  sub dispatch { Line 245  sub dispatch {
245    
246  sub database_get {  sub database_get {
247          my ($db_name) = @_;          my ($db_name) = @_;
248            my $path = $config->{path};
249          warn "# collecting docs from $path/$db_name/*\n";          warn "# collecting docs from $path/$db_name/*\n";
250          my @docs = glob "$path/$db_name/*";          my @docs = glob "$path/$db_name/*";
251          my $json = {          my $json = {
# Line 155  sub database_get { Line 260  sub database_get {
260          };          };
261    
262          warn "## calculating disk_size\n";          warn "## calculating disk_size\n";
263          $json->{disk_size} += -s "$path/$1/$_" foreach $docs;          $json->{disk_size} += -s $_ foreach @docs;
264          $status = 200;          $status = 200;
265          return $json;          return $json;
266  }  }
Legend:
Removed from v.1047  
changed lines
  Added in v.1050
  ViewVC Help
Powered by ViewVC 1.1.26