CouchDB view push/pull script

[pxelator] / couchdb / design-couch.pl

diff --git a/couchdb/design-couch.pl b/couchdb/design-couch.pl
new file mode 100755 (executable)
index 0000000..4cf9606
--- /dev/null
+++ b/couchdb/design-couch.pl
@@ -0,0 +1,175 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+use LWP::UserAgent;
+use JSON;
+use Data::Dump qw/dump/;
+use File::Path qw/mkpath/;
+use File::Slurp qw//;
+use File::Find;
+use HTTP::Request::Common;
+use MIME::Base64;
+
+use lib qw(lib ../lib);
+use Media::Type::Simple;
+
+
+# design-couch.pl
+#
+# 04/26/09 21:12:28 CEST Dobrica Pavlinusic <dpavlin@rot13.org>
+
+my ( $command, $database, $design ) = @ARGV;
+die "usage: $0 [push|pull] database design\n" unless $database && $design;
+
+chdir $design || die "can't find $design: $!";
+
+my $ua = LWP::UserAgent->new;
+
+my $url = "http://localhost:5984/$database/_design/$design";
+
+sub create_path {
+       my $path = shift;
+       if ( $path =~ m{/} ) {
+               my $dir = $path;
+               $dir =~ s{/[^/]+$}{};
+               mkpath $dir if ! -e $dir;
+               #warn "# dir $dir";
+       }
+}
+sub write_file {
+       my ( $path, $content ) = @_;
+       $path =~ s{^/+}{};
+       create_path $path;
+       File::Slurp::write_file $path, $content;
+       print "$path ", -s $path, " bytes created\n";
+}
+
+sub write_attachment {
+       my ( $path ) = @_;
+       my $file = "_attachemnts/$path";
+       create_path $file;
+       $ua->mirror( "$url/$path", $file );
+       print "detached $file ", -s $file, " bytes\n";
+}
+
+
+sub unroll {
+       my ( $tree, $path ) = @_;
+
+       my $ref = ref $tree;
+       if ( $ref eq 'HASH' ) {
+               foreach my $child ( keys %$tree ) {
+                       if ( $child eq '_attachments' ) {
+                               write_attachment $_ foreach keys %{ $tree->{$child} };
+                       } else {
+                               unroll( $tree->{$child}, $path ? "$path/$child" : $child );
+                       }
+               }
+       } elsif ( $ref ) {
+               warn "UNSUPPORTED $path $ref ", dump( $tree );
+               write_file "$path.json", to_json $tree;
+       } elsif ( $ref eq '' ) {
+
+               if ( $tree =~ m[^\s*(function(.*){.*}|/\*|//|var)]is ) {
+                       $path .= '.js';
+               } elsif ( $tree =~ m{<%=.*%>} ) { # couchapp template
+                       $path .= '.html';
+               } else {
+                       warn "# can't detect type of $path\n";
+               }
+
+               write_file $path, $tree;
+       }
+
+}
+
+if ( $command eq 'pull' ) {
+
+       warn "# get $url\n";
+       my $response = $ua->get( $url );
+       die $response->status_line if $response->is_error;
+
+       my $json = $response->decoded_content;
+       write_file "../$database-$design.pull.js", $json;
+
+       unroll( from_json $json, '' );
+
+} elsif ( $command eq 'push' ) {
+
+       my $json;
+
+       find({ no_chdir => 1, wanted => sub {
+               my $path = $File::Find::name;
+               return unless -f $path;
+
+warn "## $path\n";
+
+               $path =~ s{^\./}{};
+
+               if ( $path =~ m{_attachemnts/(.+)} ) {
+
+                       my $filename = $1;
+                       my $content_type = 'text/plain';
+                       $content_type = type_from_ext($1) if $filename =~ m{\.(\w+)$};
+
+                       my $data = File::Slurp::read_file( $path );
+                       $data = encode_base64( $data );
+                       # XXX inline attachments must be single line
+                       # XXX http://wiki.apache.org/couchdb/HTTP_Document_API
+                       $data =~ s/[\n\r]+//gs;
+                       $json->{_attachments}->{ $filename } = {
+                               content_type => $content_type,
+                               data         => $data,
+                       };
+                       return;
+               }
+
+               my $data = File::Slurp::read_file( $path );
+               $path =~ s[/]['}->{']g;
+               $path =~ s{\.\w+$}{};
+               my $code = "\$json->{'$path'} = \$data;";
+               eval $code;
+               die "ERROR in $code: $@" if $@;
+#              warn "## json = ",dump( $json );
+       }}, '.' );
+
+       if ( ! defined $json->{_id} ) {
+               warn "creating _id for document\n";
+               $json->{_id} = $$ . '-' . time();
+       }
+       delete( $json->{_rev} ) && warn "removing _rev from document\n";
+
+       print "push $database/_design/$design\n";
+       write_file "../$database-$design.push.js", to_json $json;
+
+       warn "# put $url\n";
+       my $response = $ua->request(
+               HTTP::Request::Common::PUT(
+                       $url,
+                       'Content-Type' => 'application/json',
+                       Content => to_json $json,
+               )
+       );
+
+       if ( $response->code == 409 ) {
+               warn "## update $url\n";
+               my $response = $ua->get( $url );
+               die $response->status_line if $response->is_error;
+
+               my $data = from_json $response->decoded_content;
+               $json->{$_} = $data->{$_} foreach ( '_rev', '_id' );
+
+               $response = $ua->request( HTTP::Request::Common::PUT($url, 'Content-Type' => 'application/json', Content => to_json $json ) );
+               die $response->status_line if $response->is_error;
+               warn "push updated $url\n";
+       } else {
+               die $response->status_line if $response->is_error;
+               warn "push new $url\n";
+       }
+
+} else {
+       die "$0: unknown command $command";
+}
+