/[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 1046 by dpavlin, Wed Apr 22 22:01:06 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);
10    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 ) = @_;
# Line 18  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_\$\(\)\+\-/]+';
42    
43    our $json = {};
44    our $status = 500;
45    
46    sub ok {
47            $json = { ok => JSON::true };
48            $status = 200;
49    }
50    
 my $regex_dbs = join('|', @all_dbs);  
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;
58          warn "INFO: using Apache CouchDB emulation API $url\n";          
   
         warn "## tx = ",dump( $tx );  
   
         my $json = {};  
   
59          if ( $url eq '/' ) {          if ( $url eq '/' ) {
60                  $json = {                  $json = {
61                          couchdb => "Emulated on Frey",                          couchdb => "Welcome",
62                          version => 0,                          version => "CouchAPI $VERSION",
63                  }                  }
64          } elsif ( $url eq '/_all_dbs' ) {          } elsif ( $url eq '/_all_dbs' ) {
65                  $json = [ @all_dbs ];                  $json = [ @all_dbs ];
66          } elsif ( $url =~ m{($regex_dbs)} ) {                  $status = 200;
67                  warn "# collecting docs from $path/$1/*\n";          } elsif ( $url =~ m{^/_config/?(.+)} ) {
68                  my @docs = glob "$path/$1/*";  
69                  $json = {                  $json = { CouchAPI => $config };
70                          db_name => $1,  
71                          doc_count => $#docs + 1,                  if ( $method eq 'PUT' ) {
72                          doc_del_count => 0,  
73                          update_seq => 0,                          my $part = $1;
74                          purge_seq => 0,                          warn "## part $part";
75                          capacity_running => JSON::false,  
76                          disk_size => 0,                          $part =~ s!^!->{'!;
77                          instance_start_time => time(),                          $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)/$} ) {
102    
103                    my $database = $1;
104                    my $dir = "$config->{path}/$database";
105    
106                    if ( $method eq 'GET' ) {
107                            $json = database_get( $database );
108                    } elsif ( $method eq 'DELETE' ) {
109                            if ( ! -e $dir ) {
110                                    $status = 404;
111                            } else {
112                                    remove_tree($dir) && ok || { $status = 501 };
113                            }
114                    } elsif ( $method eq 'PUT' ) {
115                            if ( ! -e $dir ) {
116                                    make_path($dir) && ok && warn "created $dir" || { $status = 501 };
117                            } else {
118                                    $status = 412;
119                            }
120                    }
121    
122            } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
123                    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";
138                    warn "## database: $database id: $id -> $p [$args]\n";
139    
140    
141                    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/}{};
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/*" );
163    
164                            warn "## docs ", dump( @docs ) if $debug;
165    
166                            $json = {
167                                    total_rows =>  $total_rows,
168                                    offset => $offset,
169                                    rows => [],
170                            };
171    
172                            my $rows;
173                            my @ids;
174    
175                            foreach my $id ( @docs ) {
176                                    warn "++ $id\n" if $debug;
177                                    my $p = "$path/$database/$id";
178                                    my $data = eval { Storable::retrieve( $p ) };
179                                    if ( $@ ) {
180                                            warn "ERROR: $p | $@\n";
181                                            next;
182                                    }
183                                    push @ids, $id;
184                                    $rows->{$id} = {
185                                            id => $id,
186                                            key => $id,
187                                            value => {
188                                                    rev => (stat($p))[9], # mtime
189                                            }
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' ) {
204            
205                            warn "## ",dump( $tx->req ) if $debug;
206    
207                            my $data = $tx->req->content->file->slurp;
208    
209                            Storable::store( from_json($data), $p );
210                            warn "store $p ", -s $p, " bytes: $data\n";
211                    } elsif ( $method eq 'GET' ) {
212                            if ( ! -e $p ) {
213                                    $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 {
225                            $status = 501;
226                    }
227    
228                    warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;
229    
                 warn "## calculating disk_size\n";  
                 $json->{disk_size} += -s "$path/$1/$_" foreach $docs;  
230          }          }
231    
232          $tx->res->code( 200 );          if ( $status >= 400 && $status < 500 && ! defined $json) {
233                    $json = { error => 'not_found', reason => 'Missing' };
234                    warn "fake $status";
235            }
236    
237            $tx->res->code( $status );
238          $tx->res->headers->content_type( 'text/json' );          $tx->res->headers->content_type( 'text/json' );
239          $tx->res->body( to_json $json );          my $body = to_json $json;
240            $tx->res->body( $body );
241            warn "CouchDB API: $method $url $status $body\n";
242          return $tx;          return $tx;
243    
244  }  }
245    
246    sub database_get {
247            my ($db_name) = @_;
248            my $path = $config->{path};
249            warn "# collecting docs from $path/$db_name/*\n";
250            my @docs = glob "$path/$db_name/*";
251            my $json = {
252                    db_name => $db_name,
253                    doc_count => $#docs + 1,
254                    doc_del_count => 0,
255                    update_seq => 0,
256                    purge_seq => 0,
257                    capacity_running => JSON::false,
258                    disk_size => 0,
259                    instance_start_time => time(),
260            };
261    
262            warn "## calculating disk_size\n";
263            $json->{disk_size} += -s $_ foreach @docs;
264            $status = 200;
265            return $json;
266    }
267    
268  1;  1;
Legend:
Removed from v.1046  
changed lines
  Added in v.1050
  ViewVC Help
Powered by ViewVC 1.1.26