/[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 1048 by dpavlin, Wed Apr 22 23:38:10 2009 UTC revision 1049 by dpavlin, Thu Apr 23 17:26:04 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 .= '-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';  my $path = '/data/webpac2/var/ds';
32  my @all_dbs = map {  my @all_dbs = map {
33          s{^\Q$path\E/*}{};          s{^\Q$path\E/*}{};
34          $_;          $_;
# Line 29  my @all_dbs = map { Line 37  my @all_dbs = map {
37  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
38    
39  our $json = {};  our $json = {};
40  our $stauts = 500;  our $status = 500;
41    
42  sub ok {  sub ok {
43          $json = { ok => JSON::true };          $json = { ok => JSON::true };
# Line 43  sub dispatch { Line 51  sub dispatch {
51          $url = uri_unescape( $url );          $url = uri_unescape( $url );
52          my $method = $tx->req->method;          my $method = $tx->req->method;
53    
         warn "INFO: using Apache CouchDB emulation API\n";  
   
54          if ( $url eq '/' ) {          if ( $url eq '/' ) {
55                  $json = {                  $json = {
56                          couchdb => "Welcome",                          couchdb => "Welcome",
57                          version => "0-Frey",                          version => $VERSION,
58                  }                  }
59          } elsif ( $url eq '/_all_dbs' ) {          } elsif ( $url eq '/_all_dbs' ) {
60                  $json = [ @all_dbs ];                  $json = [ @all_dbs ];
61                  $status = 200;                  $status = 200;
62            } elsif ( $url =~ m{^/_config} ) {
63                    $json = {
64                            couchdb => {
65                                    version => $VERSION,
66                                    path => $path,
67                            }
68                    };
69                    $status = 200;
70          } elsif ( $url =~ m{($regex_dbs)/$} ) {          } elsif ( $url =~ m{($regex_dbs)/$} ) {
71    
72                  my $database = $1;                  my $database = $1;
# Line 74  sub dispatch { Line 88  sub dispatch {
88                          }                          }
89                  }                  }
90    
91          } elsif ( $url =~ m{($regex_dbs)/(.+)$} ) {          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
92                  my ($database,$id) = ($1,$2);                  my ($database,$id,$args) = ($1,$2,$3);
93    
94                    my $arg;
95                    if ( $args ) {
96                            foreach my $a ( split(/[&;]/,$args) ) {
97                                    my ($n,$v) = split(/=/,$a);
98                                    $v =~ s{(["'])(.+)\1}{$2};
99                                    $arg->{$n} = $v;
100                            }
101                    }
102                    
103                  my $p = "$path/$database/$id";                  my $p = "$path/$database/$id";
104                  warn "## database: $database id: $id -> $p ";                  warn "## database: $database id: $id -> $p [$args]\n";
105    
                 if ( $id eq '_all_docs' ) {  
106    
107                          my @docs = map {                  if ( $id =~ m{_all_docs(\w+)?$} ) {
108    
109                            my $by = $1;
110                            my $offset = 0;
111                            my $startkey = delete $arg->{startkey};
112    warn "STARTKEY: $startkey\n";
113                            my $total_rows = 0;
114    
115                            my @docs = grep { length $_ } map {
116                                  s{^$path/$database/}{};                                  s{^$path/$database/}{};
117                                  $_;                                  if ( $startkey ) {
118                                            if ( $_ >= $startkey ) {
119                                                    $total_rows++;
120                                                    $_;
121                                            } else {
122                                                    $offset++;
123                                            }
124                                    } else {
125                                            $total_rows++;
126                                            $_;
127                                    }
128                          } glob( "$path/$database/*" );                          } glob( "$path/$database/*" );
129    
130                          warn "## docs ", dump( @docs );                          warn "## docs ", dump( @docs );
131    
132                          $json = {                          $json = {
133                                  total_rows =>  $#docs + 1,                                  total_rows =>  $total_rows,
134                                  offset => 0,                                  offset => $offset,
135                                  rows => [],                                  rows => [],
136                          };                          };
137    
138                            my $rows;
139                            my @ids;
140    
141                          foreach my $id ( @docs ) {                          foreach my $id ( @docs ) {
142                                  warn "++ $id\n";                                  warn "++ $id\n" if $debug;
143                                  my $p = "$path/$database/$id";                                  my $p = "$path/$database/$id";
144                                  my $data = Storable::retrieve( $p );                                  my $data = eval { Storable::retrieve( $p ) };
145                                  push @{ $json->{rows} }, {                                  if ( $@ ) {
146                                            warn "ERROR: $p | $@\n";
147                                            next;
148                                    }
149                                    push @ids, $id;
150                                    $rows->{$id} = {
151                                          id => $id,                                          id => $id,
152                                          key => $id,                                          key => $id,
153                                          value => {                                          value => {
# Line 108  sub dispatch { Line 156  sub dispatch {
156                                  };                                  };
157                          }                          }
158    
159                            my $descending = delete $arg->{descending};
160                            my @sorted = sort @ids;
161    
162                            foreach my $id ( $descending ? reverse @sorted : @sorted ) {
163                                    warn ">> $id ", $descending ? 'desc' : 'asc', "\n";
164                                    push @{ $json->{rows} }, $rows->{$id};
165                            }
166    
167                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
168                    
169                          warn "## ",dump( $tx->req );                          warn "## ",dump( $tx->req ) if $debug;
170    
171                          my $data = $tx->req->content->file->slurp;                          my $data = $tx->req->content->file->slurp;
172    
173                          Storable::store( from_json($data), $p );                          Storable::store( from_json($data), $p );
174                          warn "store $p ", -s $p, " bytes: $data\n";                          warn "store $p ", -s $p, " bytes: $data\n";
175                  } elsif ( $method eq 'GET' ) {                  } elsif ( $method eq 'GET' ) {
176                          warn "retrive $p ", -s $p, " bytes\n";                          if ( ! -e $p ) {
177                          $json = Storable::retrieve( $p );                                  $status = 404;
178                            } else {
179                                    warn "retrive $p ", -s $p, " bytes\n";
180                                    $json = Storable::retrieve( $p );
181                            }
182                    } elsif ( $method eq 'DELETE' ) {
183                            if ( -e $p ) {
184                                    unlink $p || { $status = 501 };
185                            } else {
186                                    $status = 404;
187                            }
188                  } else {                  } else {
189                          $status = 501;                          $status = 501;
190                  }                  }
191    
192                    warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;
193    
194          }          }
195    
196          if ( $status >= 400 && $status < 500 && ! defined $json) {          if ( $status >= 400 && $status < 500 && ! defined $json) {
# Line 155  sub database_get { Line 223  sub database_get {
223          };          };
224    
225          warn "## calculating disk_size\n";          warn "## calculating disk_size\n";
226          $json->{disk_size} += -s "$path/$1/$_" foreach $docs;          $json->{disk_size} += -s $_ foreach @docs;
227          $status = 200;          $status = 200;
228          return $json;          return $json;
229  }  }
Legend:
Removed from v.1048  
changed lines
  Added in v.1049
  ViewVC Help
Powered by ViewVC 1.1.26