Repository List / pxelator / couchdb / design-couch.pl @ HEAD

#!/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 autodie;

use lib qw(lib ../lib);
use Media::Type::Simple;


# design-couch.pl
#
# 04/26/09 21:12:28 CEST Dobrica Pavlinusic <dpavlin@rot13.org>

our $couchdb = $ENV{COUCHDB} || 'http://localhost:5984/';

our ( $command, $database, $design ) = @ARGV;

die "usage: $0 [push|pull] database [design]\n" unless $database;


my $ua = LWP::UserAgent->new;

sub create_path {
	my $path = shift;
	if ( $path =~ m{/} ) {
		my $dir = $path;
		$dir =~ s{/[^/]+$}{};
		mkpath $dir if ! -e $dir;
		#warn "# dir $dir";
	}
}

sub svn {
	my $path = shift;
	return if $path =~ m{(_.*|.*\.(push|pull)\.js)$};
	system "svn add --parents $path";
}

sub write_file {
	my ( $path, $content ) = @_;
	$path =~ s{^/+}{};
	create_path $path;
	File::Slurp::write_file $path, $content;
	print "$path ", -s $path, " bytes created\n";
	svn $path;
}

sub write_attachment {
	my ( $path ) = @_;
	my $file = "_attachemnts/$path";
	create_path $file;
	$ua->mirror( "$couchdb/$database/_design/$design/$path", $file );
	print "detached $file ", -s $file, " bytes\n";
	svn $file;
}


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;
	}

}

sub pull_design {
	$design = shift;

	my $url = "$couchdb/$database/_design/$design";

	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, '' );

}

sub push_design {
	$design = shift;

	$ua->request( HTTP::Request::Common::PUT( "http://localhost:5984/$database" ) ) && warn "# created database $database\n";

	my $json;

	find({ no_chdir => 1, wanted => sub {
		my $path = $File::Find::name;
		return unless -f $path;
		return if $path =~ m{/\.svn};

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;

	my $url = "$couchdb/$database/_design/$design";
	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";
	}
}


# XXX main


if ( $command eq 'push' ) {

	my @designs = map { s{/.+$}{}; $_ } glob '*/views';
	@designs = ( $design ) if $design;

	foreach my $design ( @designs ) {

		chdir $design;
		push_design( $design );
		chdir '..';

	}

} elsif ( $command eq 'pull' ) {

	my $designs = from_json $ua->get( "$couchdb/$database/_all_docs?startkey=%22_design%2F%22&endkey=%22_design0%22" )->decoded_content;
	my @designs =
		map {
			my $name = $_->{id};
			$name =~ s{^_design/}{};
			$name;
		} @{ $designs->{rows} }
	;

	warn "# $database/_design ",dump( @designs );

	@designs = ( $design ) if $design;

	foreach my $design ( @designs ) {

		mkdir $design unless -e $design;
		chdir $design;
		pull_design( $design );
		chdir '..';

	}

} else {
	die "$0: unknown command $command";
}