1 |
dpavlin |
1046 |
package Frey::CouchAPI; |
2 |
|
|
|
3 |
|
|
use JSON; |
4 |
|
|
use Data::Dump qw/dump/; |
5 |
|
|
use URI::Escape; |
6 |
dpavlin |
1047 |
use File::Path qw(make_path remove_tree); |
7 |
|
|
use Storable; |
8 |
dpavlin |
1046 |
|
9 |
|
|
sub rewrite_urls { |
10 |
|
|
my ( $self, $tx ) = @_; |
11 |
|
|
if ( $tx->req->url->path =~ m{/_utils/} ) { |
12 |
|
|
my $path = $tx->req->url->path; |
13 |
|
|
$path =~ s{(/_utils)/?$}{$1/index.html}; # poor man's DirectoryIndex |
14 |
|
|
$path =~ s{/_utils}{/static/futon}; |
15 |
|
|
$tx->req->url->path( $path ); |
16 |
|
|
my $url = $tx->req->url->to_string; |
17 |
|
|
my $old = $url; |
18 |
|
|
$url = $tx->req->url->to_string; |
19 |
|
|
warn "# rewrite $old -> $url\n"; |
20 |
|
|
} |
21 |
|
|
} |
22 |
|
|
|
23 |
|
|
my $path = '/data/webpac2/var/row'; |
24 |
|
|
my @all_dbs = map { |
25 |
|
|
s{^\Q$path\E/*}{}; |
26 |
|
|
$_; |
27 |
|
|
} glob "$path/*/*"; |
28 |
|
|
|
29 |
dpavlin |
1047 |
my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+'; |
30 |
dpavlin |
1046 |
|
31 |
dpavlin |
1047 |
our $json = {}; |
32 |
|
|
our $stauts = 500; |
33 |
|
|
|
34 |
|
|
sub ok { |
35 |
|
|
$json = { ok => JSON::true }; |
36 |
|
|
$status = 200; |
37 |
|
|
} |
38 |
|
|
|
39 |
dpavlin |
1046 |
sub dispatch { |
40 |
|
|
my ($self,$tx) = @_; |
41 |
|
|
|
42 |
|
|
my $url = $tx->req->url->to_string; |
43 |
|
|
$url = uri_unescape( $url ); |
44 |
dpavlin |
1047 |
my $method = $tx->req->method; |
45 |
dpavlin |
1046 |
|
46 |
dpavlin |
1047 |
warn "INFO: using Apache CouchDB emulation API\n"; |
47 |
dpavlin |
1046 |
|
48 |
|
|
if ( $url eq '/' ) { |
49 |
|
|
$json = { |
50 |
dpavlin |
1047 |
couchdb => "Welcome", |
51 |
|
|
version => "0-Frey", |
52 |
dpavlin |
1046 |
} |
53 |
|
|
} elsif ( $url eq '/_all_dbs' ) { |
54 |
|
|
$json = [ @all_dbs ]; |
55 |
dpavlin |
1047 |
$status = 200; |
56 |
|
|
} elsif ( $url =~ m{($regex_dbs)/$} ) { |
57 |
dpavlin |
1046 |
|
58 |
dpavlin |
1047 |
my $database = $1; |
59 |
|
|
my $dir = "$path/$database"; |
60 |
|
|
|
61 |
|
|
if ( $method eq 'GET' ) { |
62 |
|
|
$json = database_get( $database ); |
63 |
|
|
} elsif ( $method eq 'DELETE' ) { |
64 |
|
|
if ( ! -e $dir ) { |
65 |
|
|
$status = 404; |
66 |
|
|
} else { |
67 |
|
|
remove_tree($dir) && ok || { $status = 501 }; |
68 |
|
|
} |
69 |
|
|
} elsif ( $method eq 'PUT' ) { |
70 |
|
|
if ( ! -e $dir ) { |
71 |
|
|
make_path($dir) && ok && warn "created $dir" || { $status = 501 }; |
72 |
|
|
} else { |
73 |
|
|
$status = 412; |
74 |
|
|
} |
75 |
|
|
} |
76 |
|
|
|
77 |
|
|
} elsif ( $url =~ m{($regex_dbs)/(.+)$} ) { |
78 |
|
|
my ($database,$id) = ($1,$2); |
79 |
|
|
|
80 |
|
|
my $p = "$path/$database/$id"; |
81 |
|
|
warn "## database: $database id: $id -> $p "; |
82 |
|
|
|
83 |
|
|
if ( $id eq '_all_docs' ) { |
84 |
|
|
|
85 |
|
|
my @docs = map { |
86 |
|
|
s{^$path/$database/}{}; |
87 |
|
|
$_; |
88 |
|
|
} glob( "$path/$database/*" ); |
89 |
|
|
|
90 |
|
|
warn "## docs ", dump( @docs ); |
91 |
|
|
|
92 |
|
|
$json = { |
93 |
|
|
total_rows => $#docs + 1, |
94 |
|
|
offset => 0, |
95 |
|
|
rows => [], |
96 |
|
|
}; |
97 |
|
|
|
98 |
|
|
foreach my $id ( @docs ) { |
99 |
|
|
warn "++ $id\n"; |
100 |
|
|
my $p = "$path/$database/$id"; |
101 |
|
|
my $data = Storable::retrieve( $p ); |
102 |
|
|
push @{ $json->{rows} }, { |
103 |
|
|
id => $id, |
104 |
|
|
key => $id, |
105 |
|
|
value => { |
106 |
|
|
rev => (stat($p))[9], # mtime |
107 |
|
|
} |
108 |
|
|
}; |
109 |
|
|
} |
110 |
|
|
|
111 |
|
|
} elsif ( $method eq 'PUT' ) { |
112 |
|
|
|
113 |
|
|
warn "## ",dump( $tx->req ); |
114 |
|
|
|
115 |
|
|
my $data = $tx->req->content->file->slurp; |
116 |
|
|
|
117 |
|
|
Storable::store( from_json($data), $p ); |
118 |
|
|
warn "store $p ", -s $p, " bytes: $data\n"; |
119 |
|
|
} elsif ( $method eq 'GET' ) { |
120 |
|
|
warn "retrive $p ", -s $p, " bytes\n"; |
121 |
|
|
$json = Storable::retrieve( $p ); |
122 |
|
|
} else { |
123 |
|
|
$status = 501; |
124 |
|
|
} |
125 |
|
|
|
126 |
dpavlin |
1046 |
} |
127 |
|
|
|
128 |
dpavlin |
1047 |
if ( $status >= 400 && $status < 500 && ! defined $json) { |
129 |
|
|
$json = { error => 'not_found', reason => 'Missing' }; |
130 |
|
|
warn "fake $status"; |
131 |
|
|
} |
132 |
|
|
|
133 |
|
|
$tx->res->code( $status ); |
134 |
dpavlin |
1046 |
$tx->res->headers->content_type( 'text/json' ); |
135 |
dpavlin |
1047 |
my $body = to_json $json; |
136 |
|
|
$tx->res->body( $body ); |
137 |
|
|
warn "CouchDB API: $method $url $status $body\n"; |
138 |
dpavlin |
1046 |
return $tx; |
139 |
|
|
|
140 |
|
|
} |
141 |
|
|
|
142 |
dpavlin |
1047 |
sub database_get { |
143 |
|
|
my ($db_name) = @_; |
144 |
|
|
warn "# collecting docs from $path/$db_name/*\n"; |
145 |
|
|
my @docs = glob "$path/$db_name/*"; |
146 |
|
|
my $json = { |
147 |
|
|
db_name => $db_name, |
148 |
|
|
doc_count => $#docs + 1, |
149 |
|
|
doc_del_count => 0, |
150 |
|
|
update_seq => 0, |
151 |
|
|
purge_seq => 0, |
152 |
|
|
capacity_running => JSON::false, |
153 |
|
|
disk_size => 0, |
154 |
|
|
instance_start_time => time(), |
155 |
|
|
}; |
156 |
|
|
|
157 |
|
|
warn "## calculating disk_size\n"; |
158 |
|
|
$json->{disk_size} += -s "$path/$1/$_" foreach $docs; |
159 |
|
|
$status = 200; |
160 |
|
|
return $json; |
161 |
|
|
} |
162 |
|
|
|
163 |
dpavlin |
1046 |
1; |