/[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 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);
10    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 ) = @_;
# Line 18  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          $_;          $_;
35  } glob "$path/*/*";  } glob "$path/*/*";
36    
37  my $regex_dbs = join('|', @all_dbs);  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
38    
39    our $json = {};
40    our $status = 500;
41    
42    sub ok {
43            $json = { ok => JSON::true };
44            $status = 200;
45    }
46    
47  sub dispatch {  sub dispatch {
48          my ($self,$tx) = @_;          my ($self,$tx) = @_;
49    
50          my $url = $tx->req->url->to_string;          my $url = $tx->req->url->to_string;
51          $url = uri_unescape( $url );          $url = uri_unescape( $url );
52            my $method = $tx->req->method;
         warn "INFO: using Apache CouchDB emulation API $url\n";  
   
         warn "## tx = ",dump( $tx );  
   
         my $json = {};  
53    
54          if ( $url eq '/' ) {          if ( $url eq '/' ) {
55                  $json = {                  $json = {
56                          couchdb => "Emulated on Frey",                          couchdb => "Welcome",
57                          version => 0,                          version => $VERSION,
58                  }                  }
59          } elsif ( $url eq '/_all_dbs' ) {          } elsif ( $url eq '/_all_dbs' ) {
60                  $json = [ @all_dbs ];                  $json = [ @all_dbs ];
61          } elsif ( $url =~ m{($regex_dbs)} ) {                  $status = 200;
62                  warn "# collecting docs from $path/$1/*\n";          } elsif ( $url =~ m{^/_config} ) {
                 my @docs = glob "$path/$1/*";  
63                  $json = {                  $json = {
64                          db_name => $1,                          couchdb => {
65                          doc_count => $#docs + 1,                                  version => $VERSION,
66                          doc_del_count => 0,                                  path => $path,
67                          update_seq => 0,                          }
                         purge_seq => 0,  
                         capacity_running => JSON::false,  
                         disk_size => 0,  
                         instance_start_time => time(),  
68                  };                  };
69                    $status = 200;
70            } elsif ( $url =~ m{($regex_dbs)/$} ) {
71    
72                  warn "## calculating disk_size\n";                  my $database = $1;
73                  $json->{disk_size} += -s "$path/$1/$_" foreach $docs;                  my $dir = "$path/$database";
74    
75                    if ( $method eq 'GET' ) {
76                            $json = database_get( $database );
77                    } elsif ( $method eq 'DELETE' ) {
78                            if ( ! -e $dir ) {
79                                    $status = 404;
80                            } else {
81                                    remove_tree($dir) && ok || { $status = 501 };
82                            }
83                    } elsif ( $method eq 'PUT' ) {
84                            if ( ! -e $dir ) {
85                                    make_path($dir) && ok && warn "created $dir" || { $status = 501 };
86                            } else {
87                                    $status = 412;
88                            }
89                    }
90    
91            } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
92                    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";
104                    warn "## database: $database id: $id -> $p [$args]\n";
105    
106    
107                    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/}{};
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/*" );
129    
130                            warn "## docs ", dump( @docs );
131    
132                            $json = {
133                                    total_rows =>  $total_rows,
134                                    offset => $offset,
135                                    rows => [],
136                            };
137    
138                            my $rows;
139                            my @ids;
140    
141                            foreach my $id ( @docs ) {
142                                    warn "++ $id\n" if $debug;
143                                    my $p = "$path/$database/$id";
144                                    my $data = eval { Storable::retrieve( $p ) };
145                                    if ( $@ ) {
146                                            warn "ERROR: $p | $@\n";
147                                            next;
148                                    }
149                                    push @ids, $id;
150                                    $rows->{$id} = {
151                                            id => $id,
152                                            key => $id,
153                                            value => {
154                                                    rev => (stat($p))[9], # mtime
155                                            }
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' ) {
168            
169                            warn "## ",dump( $tx->req ) if $debug;
170    
171                            my $data = $tx->req->content->file->slurp;
172    
173                            Storable::store( from_json($data), $p );
174                            warn "store $p ", -s $p, " bytes: $data\n";
175                    } elsif ( $method eq 'GET' ) {
176                            if ( ! -e $p ) {
177                                    $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 {
189                            $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) {
197                    $json = { error => 'not_found', reason => 'Missing' };
198                    warn "fake $status";
199          }          }
200    
201          $tx->res->code( 200 );          $tx->res->code( $status );
202          $tx->res->headers->content_type( 'text/json' );          $tx->res->headers->content_type( 'text/json' );
203          $tx->res->body( to_json $json );          my $body = to_json $json;
204            $tx->res->body( $body );
205            warn "CouchDB API: $method $url $status $body\n";
206          return $tx;          return $tx;
207    
208  }  }
209    
210    sub database_get {
211            my ($db_name) = @_;
212            warn "# collecting docs from $path/$db_name/*\n";
213            my @docs = glob "$path/$db_name/*";
214            my $json = {
215                    db_name => $db_name,
216                    doc_count => $#docs + 1,
217                    doc_del_count => 0,
218                    update_seq => 0,
219                    purge_seq => 0,
220                    capacity_running => JSON::false,
221                    disk_size => 0,
222                    instance_start_time => time(),
223            };
224    
225            warn "## calculating disk_size\n";
226            $json->{disk_size} += -s $_ foreach @docs;
227            $status = 200;
228            return $json;
229    }
230    
231  1;  1;
Legend:
Removed from v.1046  
changed lines
  Added in v.1049
  ViewVC Help
Powered by ViewVC 1.1.26