git.rot13.org Git - pxelator/blob - couchdb/design-couch.pl

   1 #!/usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5
   6 use LWP::UserAgent;
   7 use JSON;
   8 use Data::Dump qw/dump/;
   9 use File::Path qw/mkpath/;
  10 use File::Slurp qw//;
  11 use File::Find;
  12 use HTTP::Request::Common;
  13 use MIME::Base64;
  14 use autodie;
  15
  16 use lib qw(lib ../lib);
  17 use Media::Type::Simple;
  18
  19
  20 # design-couch.pl
  21 #
  22 # 04/26/09 21:12:28 CEST Dobrica Pavlinusic <dpavlin@rot13.org>
  23
  24 our $couchdb = $ENV{COUCHDB} || 'http://localhost:5984/';
  25
  26 our ( $command, $database, $design ) = @ARGV;
  27
  28 die "usage: $0 [push|pull] database [design]\n" unless $database;
  29
  30
  31 my $ua = LWP::UserAgent->new;
  32
  33 sub create_path {
  34         my $path = shift;
  35         if ( $path =~ m{/} ) {
  36                 my $dir = $path;
  37                 $dir =~ s{/[^/]+$}{};
  38                 mkpath $dir if ! -e $dir;
  39                 #warn "# dir $dir";
  40         }
  41 }
  42
  43 sub svn {
  44         my $path = shift;
  45         return if $path =~ m{(_.*|.*\.(push|pull)\.js)$};
  46         system "svn add --parents $path";
  47 }
  48
  49 sub write_file {
  50         my ( $path, $content ) = @_;
  51         $path =~ s{^/+}{};
  52         create_path $path;
  53         File::Slurp::write_file $path, $content;
  54         print "$path ", -s $path, " bytes created\n";
  55         svn $path;
  56 }
  57
  58 sub write_attachment {
  59         my ( $path ) = @_;
  60         my $file = "_attachemnts/$path";
  61         create_path $file;
  62         $ua->mirror( "$couchdb/$database/_design/$design/$path", $file );
  63         print "detached $file ", -s $file, " bytes\n";
  64         svn $file;
  65 }
  66
  67
  68 sub unroll {
  69         my ( $tree, $path ) = @_;
  70
  71         my $ref = ref $tree;
  72         if ( $ref eq 'HASH' ) {
  73                 foreach my $child ( keys %$tree ) {
  74                         if ( $child eq '_attachments' ) {
  75                                 write_attachment $_ foreach keys %{ $tree->{$child} };
  76                         } else {
  77                                 unroll( $tree->{$child}, $path ? "$path/$child" : $child );
  78                         }
  79                 }
  80         } elsif ( $ref ) {
  81                 warn "UNSUPPORTED $path $ref ", dump( $tree );
  82                 write_file "$path.json", to_json $tree;
  83         } elsif ( $ref eq '' ) {
  84
  85                 if ( $tree =~ m[^\s*(function(.*){.*}|/\*|//|var)]is ) {
  86                         $path .= '.js';
  87                 } elsif ( $tree =~ m{<%=.*%>} ) { # couchapp template
  88                         $path .= '.html';
  89                 } else {
  90                         warn "# can't detect type of $path\n";
  91                 }
  92
  93                 write_file $path, $tree;
  94         }
  95
  96 }
  97
  98 sub pull_design {
  99         $design = shift;
 100
 101         my $url = "$couchdb/$database/_design/$design";
 102
 103         warn "# get $url\n";
 104         my $response = $ua->get( $url );
 105         die $response->status_line if $response->is_error;
 106
 107         my $json = $response->decoded_content;
 108         write_file "../$database-$design.pull.js", $json;
 109
 110         unroll( from_json $json, '' );
 111
 112 }
 113
 114 sub push_design {
 115         $design = shift;
 116
 117         $ua->request( HTTP::Request::Common::PUT( "http://localhost:5984/$database" ) ) && warn "# created database $database\n";
 118
 119         my $json;
 120
 121         find({ no_chdir => 1, wanted => sub {
 122                 my $path = $File::Find::name;
 123                 return unless -f $path;
 124                 return if $path =~ m{/\.svn};
 125
 126 warn "## $path\n";
 127
 128                 $path =~ s{^\./}{};
 129
 130                 if ( $path =~ m{_attachemnts/(.+)} ) {
 131
 132                         my $filename = $1;
 133                         my $content_type = 'text/plain';
 134                         $content_type = type_from_ext($1) if $filename =~ m{\.(\w+)$};
 135
 136                         my $data = File::Slurp::read_file( $path );
 137                         $data = encode_base64( $data );
 138                         # XXX inline attachments must be single line
 139                         # XXX http://wiki.apache.org/couchdb/HTTP_Document_API
 140                         $data =~ s/[\n\r]+//gs;
 141                         $json->{_attachments}->{ $filename } = {
 142                                 content_type => $content_type,
 143                                 data         => $data,
 144                         };
 145                         return;
 146                 }
 147
 148                 my $data = File::Slurp::read_file( $path );
 149                 $path =~ s[/]['}->{']g;
 150                 $path =~ s{\.\w+$}{};
 151                 my $code = "\$json->{'$path'} = \$data;";
 152                 eval $code;
 153                 die "ERROR in $code: $@" if $@;
 154 #               warn "## json = ",dump( $json );
 155         }}, '.' );
 156
 157         if ( ! defined $json->{_id} ) {
 158                 warn "creating _id for document\n";
 159                 $json->{_id} = $$ . '-' . time();
 160         }
 161         delete( $json->{_rev} ) && warn "removing _rev from document\n";
 162
 163         print "push $database/_design/$design\n";
 164         write_file "../$database-$design.push.js", to_json $json;
 165
 166         my $url = "$couchdb/$database/_design/$design";
 167         warn "# put $url\n";
 168         my $response = $ua->request(
 169                 HTTP::Request::Common::PUT(
 170                         $url,
 171                         'Content-Type' => 'application/json',
 172                         Content => to_json $json,
 173                 )
 174         );
 175
 176         if ( $response->code == 409 ) {
 177                 warn "## update $url\n";
 178                 my $response = $ua->get( $url );
 179                 die $response->status_line if $response->is_error;
 180
 181                 my $data = from_json $response->decoded_content;
 182                 $json->{$_} = $data->{$_} foreach ( '_rev', '_id' );
 183
 184                 $response = $ua->request( HTTP::Request::Common::PUT($url, 'Content-Type' => 'application/json', Content => to_json $json ) );
 185                 die $response->status_line if $response->is_error;
 186                 warn "push updated $url\n";
 187         } else {
 188                 die $response->status_line if $response->is_error;
 189                 warn "push new $url\n";
 190         }
 191 }
 192
 193
 194 # XXX main
 195
 196
 197 if ( $command eq 'push' ) {
 198
 199         my @designs = map { s{/.+$}{}; $_ } glob '*/views';
 200         @designs = ( $design ) if $design;
 201
 202         foreach my $design ( @designs ) {
 203
 204                 chdir $design;
 205                 push_design( $design );
 206                 chdir '..';
 207
 208         }
 209
 210 } elsif ( $command eq 'pull' ) {
 211
 212         my $designs = from_json $ua->get( "$couchdb/$database/_all_docs?startkey=%22_design%2F%22&endkey=%22_design0%22" )->decoded_content;
 213         my @designs =
 214                 map {
 215                         my $name = $_->{id};
 216                         $name =~ s{^_design/}{};
 217                         $name;
 218                 } @{ $designs->{rows} }
 219         ;
 220
 221         warn "# $database/_design ",dump( @designs );
 222
 223         @designs = ( $design ) if $design;
 224
 225         foreach my $design ( @designs ) {
 226
 227                 mkdir $design unless -e $design;
 228                 chdir $design;
 229                 pull_design( $design );
 230                 chdir '..';
 231
 232         }
 233
 234 } else {
 235         die "$0: unknown command $command";
 236 }
 237