/[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

trunk/lib/Frey/CouchAPI.pm revision 1049 by dpavlin, Thu Apr 23 17:26:04 2009 UTC branches/zimbardo/lib/Frey/CouchAPI.pm revision 1191 by dpavlin, Mon Sep 28 20:25:07 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    You can access it using normal C</_utils/> URI, just like on real CouchDB and
8    it will bring up partially functional Futon interface against this module.
9    
10    L<Mojo::URL>
11    
12    L<Mojo::Transaction>
13    
14    
15    =head1 Supported HTTP API
16    
17    =cut
18    
19  use warnings;  use warnings;
20  use strict;  use strict;
21    
22  use JSON;  use JSON;
23  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
24  use URI::Escape;  use URI::Escape;
25  use File::Path qw(make_path remove_tree);  use File::Path;
26  use Storable;  use Storable;
27    
28  our $VERSION = '0.1';  our $VERSION = '0.3';
29  $VERSION .= '-Frey-' . $Frey::VERSION;  $VERSION .= " (Frey $Frey::VERSION)" if $Frey::VERSION;
30    
31  our $debug = $Frey::debug || 0;  our $debug = $Frey::debug || 0;
32    
# Line 28  sub rewrite_urls { Line 44  sub rewrite_urls {
44          }          }
45  }  }
46    
47  my $path = '/data/webpac2/var/ds';  our $config = {
48  my @all_dbs = map {          database => {
49          s{^\Q$path\E/*}{};                  path => '/data/webpac2/var/row',
50          $_;                  database_glob => '*/*',
51  } glob "$path/*/*";                  data_glob => '*',
52            }
53    };
54    
55    $config = {
56            data => {
57                    base_path => '/home/dpavlin/x/Frey/var/svn/home/dpavlin/private/svn',
58                    database => '*',
59                    files => '*.storable',
60            },
61    };
62    
63    sub _glob_databases {
64            my $path = $config->{data}->{base_path};
65            map {
66                    my $p = $_;
67                    $p =~ s{^$path/+}{};
68                    $p;
69            } glob "$path/$config->{data}->{database}"
70    }
71    
72  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';  sub _glob_files {
73            my $path = $config->{data}->{base_path} . '/' . shift;
74            map {
75                    my $p = $_;
76                    $p =~ s{^$path/+}{};
77                    $p;
78            } glob "$path/$config->{data}->{files}"
79    };
80    
81    my $regex_dbs = '[a-zA-Z][a-zA-Z0-9_\$\(\)\+\-/]+';
82    
83  our $json = {};  our $json = {};
84  our $status = 500;  our $status;
85    
86  sub ok {  sub ok {
87          $json = { ok => JSON::true };          $json = { ok => JSON::true };
88          $status = 200;          $status = 200;
89            warn "ok from ",join(' ',caller),$/;
90    }
91    
92    sub file_rev { (stat($_[0]))[9] } # mtime
93    
94    sub data_from_tx {
95            my $tx = shift;
96            my $data = $tx->req->content->file->slurp;
97            $data = JSON->new->allow_nonref->decode( $data );
98            warn "## data ",dump( $data );
99            return $data;
100  }  }
101    
102  sub dispatch {  sub dispatch {
103          my ($self,$tx) = @_;          my ($self,$tx) = @_;
104    
105            $status = 500; # Internal Error
106    
107          my $url = $tx->req->url->to_string;          my $url = $tx->req->url->to_string;
108          $url = uri_unescape( $url );          $url = uri_unescape( $url );
109          my $method = $tx->req->method;          my $method = $tx->req->method;
110            my $path = $config->{data}->{base_path};
111    
112            die "base_path $path doesn't exist" unless -e $path;
113    
114          if ( $url eq '/' ) {          if ( $url eq '/' ) {
115                  $json = {                  $json = {
116                          couchdb => "Welcome",                          couchdb => "Welcome",
117                          version => $VERSION,                          version => "CouchAPI $VERSION",
118                  }                  };
119                    $status = 200;
120          } elsif ( $url eq '/_all_dbs' ) {          } elsif ( $url eq '/_all_dbs' ) {
121                  $json = [ @all_dbs ];                  $json = [
122                            map {
123                                    my $db = $_;
124                                    $db =~ s{^\Q$path\E/*}{};
125                                    $db;
126                            } _glob_databases
127                    ];
128                  $status = 200;                  $status = 200;
129          } elsif ( $url =~ m{^/_config} ) {          } elsif ( $url =~ m{^/_config/?(.+)} ) {
130                  $json = {  
131                          couchdb => {                  $json = $config;
132                                  version => $VERSION,  
133                                  path => $path,                  if ( $method eq 'PUT' ) {
134    
135                            my $part = $1;
136                            my $data = data_from_tx( $tx );
137                            warn "## part $part = $data\n";
138    
139                            $part =~ s!/!'}->{'!;
140    
141                            # poor man's transaction :-)
142                            my $code = "\$config->{'$part'} = \$data;";
143                            eval $code; ## no critic
144                            if ( $@ ) {
145                                    warn "ERROR: $code -> $@";
146                                    $status = 500;
147                            } else {
148                                    $status = 200;
149                          }                          }
150                  };  
151                  $status = 200;                          warn "# config after $code is ",dump( $config ),$/;
152          } elsif ( $url =~ m{($regex_dbs)/$} ) {  
153                    } elsif ( $method eq 'GET' ) {
154                            $status = 200;
155                    } else {
156                            $status = 501;
157                    }
158    
159    =head2 Database
160    
161    L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction
162    
163    =cut
164    
165            } elsif (
166                       $url =~ m{($regex_dbs)/$}
167                    # DELETE doesn't have trailing slash
168                    || $method eq 'DELETE' && $url =~ m{($regex_dbs)$}
169            ) {
170    
171                  my $database = $1;                  my $database = $1;
172    
173                  my $dir = "$path/$database";                  my $dir = "$path/$database";
174    
175                  if ( $method eq 'GET' ) {                  if ( $method eq 'GET' ) {
# Line 78  sub dispatch { Line 178  sub dispatch {
178                          if ( ! -e $dir ) {                          if ( ! -e $dir ) {
179                                  $status = 404;                                  $status = 404;
180                          } else {                          } else {
181                                  remove_tree($dir) && ok || { $status = 501 };                                  rmtree($dir);
182                                    if ( ! -d $dir ) {
183                                            ok;
184                                    } else {
185                                            $status = 500;
186                                    }
187                          }                          }
188                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
189                          if ( ! -e $dir ) {                          if ( -e $dir ) {
                                 make_path($dir) && ok && warn "created $dir" || { $status = 501 };  
                         } else {  
190                                  $status = 412;                                  $status = 412;
191                            } else {
192                                    mkpath($dir);
193                                    if ( -e $path ) {
194                                            ok;
195                                            $status = 201;
196                                    } else {
197                                            $status = 500;
198                                    }
199                          }                          }
200                  }                  }
201    
202                    warn "## database $database $status ",dump( $json );
203    
204          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
205                  my ($database,$id,$args) = ($1,$2,$3);                  my ($database,$id,$args) = ($1,$2,$3);
206    
207    =head2 Document
208    
209    L<http://wiki.apache.org/couchdb/HTTP_Document_API>
210    
211    =cut
212    
213                  my $arg;                  my $arg;
214                  if ( $args ) {                  if ( $args ) {
215                          foreach my $a ( split(/[&;]/,$args) ) {                          foreach my $a ( split(/[&;]/,$args) ) {
# Line 99  sub dispatch { Line 218  sub dispatch {
218                                  $arg->{$n} = $v;                                  $arg->{$n} = $v;
219                          }                          }
220                  }                  }
221            
222                    warn "ERROR: path $path doesn't exist\n" unless -e $path;
223    
224                  my $p = "$path/$database/$id";                  my $p = "$path/$database/$id";
225                  warn "## database: $database id: $id -> $p [$args]\n";                  warn "## database: $database id: $id -> $p ", dump( $arg ),"\n";
226    
227    
228                  if ( $id =~ m{_all_docs(\w+)?$} ) {                  if ( $id =~ m{_all_docs(\w*)$} ) {
229    
230                          my $by = $1;                          my $by = $1;
231                          my $offset = 0;                          my $offset = 0;
232                          my $startkey = delete $arg->{startkey};                          my $startkey = delete $arg->{startkey};
233  warn "STARTKEY: $startkey\n";                             $startkey ||= delete $arg->{startkey_docid}; # XXX key == id
234                            my $endkey   = delete $arg->{endkey};
235                            my $limit    = delete $arg->{limit};
236                            my $skip     = delete $arg->{skip};
237                          my $total_rows = 0;                          my $total_rows = 0;
238                            my $collected_rows = 0;
239    
240                            my @docs = grep { length($_) > 0 } map {        ## no critic
241    
242                                    my $id = $_;
243                                    $total_rows++;
244            
245                                    if ( $limit > 0 && $collected_rows == $limit ) {
246                                            '';
247                                    } else {
248    
249                          my @docs = grep { length $_ } map {                                          if ( defined $endkey && $id gt $endkey ) {
250                                  s{^$path/$database/}{};                                                  '';
251                                  if ( $startkey ) {                                          } elsif ( $startkey ) {
252                                          if ( $_ >= $startkey ) {                                                  if ( $id ge $startkey ) {
253                                                  $total_rows++;                                                          $collected_rows++;
254                                                  $_;                                                          $id;
255                                                    } else {
256                                                            $offset++;
257                                                            '';
258                                                    }
259                                          } else {                                          } else {
260                                                  $offset++;                                                  $collected_rows++;
261                                                    $id;
262                                          }                                          }
                                 } else {  
                                         $total_rows++;  
                                         $_;  
263                                  }                                  }
                         } glob( "$path/$database/*" );  
264    
265                          warn "## docs ", dump( @docs );                          } _glob_files( $database );
266    
267                            $offset += $skip if $skip;
268    
269                            warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
270    
271                          $json = {                          $json = {
272                                  total_rows =>  $total_rows,                                  total_rows =>  $total_rows,
# Line 151  warn "STARTKEY: $startkey\n"; Line 290  warn "STARTKEY: $startkey\n";
290                                          id => $id,                                          id => $id,
291                                          key => $id,                                          key => $id,
292                                          value => {                                          value => {
293                                                  rev => (stat($p))[9], # mtime                                                  rev => file_rev $p,
294                                          }                                          }
295                                  };                                  };
296                          }                          }
# Line 159  warn "STARTKEY: $startkey\n"; Line 298  warn "STARTKEY: $startkey\n";
298                          my $descending = delete $arg->{descending};                          my $descending = delete $arg->{descending};
299                          my @sorted = sort @ids;                          my @sorted = sort @ids;
300    
301                            warn "creating rows in ", $descending ? "descending" : "", " order\n";
302    
303                          foreach my $id ( $descending ? reverse @sorted : @sorted ) {                          foreach my $id ( $descending ? reverse @sorted : @sorted ) {
304                                  warn ">> $id ", $descending ? 'desc' : 'asc', "\n";                                  warn ">> $id ", $descending ? 'desc' : 'asc', "\n" if $debug;
305                                  push @{ $json->{rows} }, $rows->{$id};                                  push @{ $json->{rows} }, $rows->{$id};
306                          }                          }
307    
308                            $status = 200;
309    
310                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
311                    
312                          warn "## ",dump( $tx->req ) if $debug;                          warn "## ",dump( $tx->req ) if $debug;
313    
314                          my $data = $tx->req->content->file->slurp;                          my $data = $tx->req->content->file->slurp;
315    
316                            my $db_path = "$path/$database";
317                            make_path $db_path unless -e $db_path;
318    
319                          Storable::store( from_json($data), $p );                          Storable::store( from_json($data), $p );
320                          warn "store $p ", -s $p, " bytes: $data\n";                          my $rev = file_rev $p;
321                            warn "store $p $rev size ", -s $p, " bytes | $data\n";
322    
323                            $status = 201; # Created
324                            $json = {
325                                    id => $id,
326                                    ok => JSON::true,
327                                    rev => $rev,
328                            };
329    
330                  } elsif ( $method eq 'GET' ) {                  } elsif ( $method eq 'GET' ) {
331                          if ( ! -e $p ) {                          if ( ! -e $p ) {
332                                  $status = 404;                                  $status = 404;
333                          } else {                          } else {
334                                  warn "retrive $p ", -s $p, " bytes\n";                                  warn "retrive $p ", -s $p, " bytes\n";
335                                  $json = Storable::retrieve( $p );                                  $json = Storable::retrieve( $p );
336                                    if ( delete $arg->{revs_info} ) {
337                                            my $rev = file_rev $p;
338                                            $json->{_rev} = $rev;
339                                            $json->{_revs_info} = [
340                                                    { rev => $rev, status => 'available' }
341                                            ];
342                                    }
343                                    $status = 200;
344    
345                          }                          }
346                  } elsif ( $method eq 'DELETE' ) {                  } elsif ( $method eq 'DELETE' ) {
347                          if ( -e $p ) {                          if ( -e $p ) {
348                                  unlink $p || { $status = 501 };                                  unlink $p && ok || { $status = 500 };
349                          } else {                          } else {
350                                  $status = 404;                                  $status = 404;
351                          }                          }
352                    } elsif ( $method eq 'POST' ) {
353                            my $data = data_from_tx( $tx );
354    
355                            # FIXME implement real view server and return 200
356                            $json = { total_rows => 0, offset => 0 };
357                            $status = 202;
358    
359                  } else {                  } else {
360                          $status = 501;                          $status = 501;
361                  }                  }
362    
363                  warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;                  if ( keys %$arg ) {
364                            warn "WARNING: arg left from $url = ",dump( $arg ),$/;
365                            $status = 501;
366                    }
367    
368          }          }
369    
370          if ( $status >= 400 && $status < 500 && ! defined $json) {          $json = { error => 'not_found', reason => 'Missing' } if $status == 404;
371                  $json = { error => 'not_found', reason => 'Missing' };  
372                  warn "fake $status";          if ( $method =~ m{(DELETE|PUT)} ) {
373    #               $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs );
374          }          }
375    
376          $tx->res->code( $status );          $tx->res->code( $status );
377          $tx->res->headers->content_type( 'text/json' );          $tx->res->headers->content_type( 'text/plain;charset=utf-8' );
378          my $body = to_json $json;          my $body = to_json $json;
379          $tx->res->body( $body );          $tx->res->body( $body );
380          warn "CouchDB API: $method $url $status $body\n";  #       $tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' );
381    #       $tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" );
382    
383            print "$method $url $status\n$body\n";
384    
385            warn "## headers ", $tx->res->headers->to_string;
386    
387          return $tx;          return $tx;
388    
389  }  }
390    
391  sub database_get {  sub database_get {
392          my ($db_name) = @_;          my ($db_name) = @_;
393          warn "# collecting docs from $path/$db_name/*\n";          warn "# collecting docs for $db_name\n";
394          my @docs = glob "$path/$db_name/*";          my @docs = _glob_files( $db_name );
395            warn dump @docs;
396          my $json = {          my $json = {
397                  db_name => $db_name,                  db_name => $db_name,
398                  doc_count => $#docs + 1,                  doc_count => $#docs + 1,
# Line 229  sub database_get { Line 411  sub database_get {
411  }  }
412    
413  1;  1;
414    __END__
415    
416    =head1 SEE ALSO
417    
418    L<http://wiki.apache.org/couchdb/Reference>
419    
Legend:
Removed from v.1049  
changed lines
  Added in v.1191
  ViewVC Help
Powered by ViewVC 1.1.26