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
  15 use lib qw(lib ../lib);
  16 use Media::Type::Simple;
  17
  18
  19 # design-couch.pl
  20 #
  21 # 04/26/09 21:12:28 CEST Dobrica Pavlinusic <dpavlin@rot13.org>
  22
  23 my ( $command, $database, $design ) = @ARGV;
  24 die "usage: $0 [push|pull] database design\n" unless $database && $design;
  25
  26 chdir $design || die "can't find $design: $!";
  27
  28 my $ua = LWP::UserAgent->new;
  29
  30 my $url = "http://localhost:5984/$database/_design/$design";
  31
  32 sub create_path {
  33         my $path = shift;
  34         if ( $path =~ m{/} ) {
  35                 my $dir = $path;
  36                 $dir =~ s{/[^/]+$}{};
  37                 mkpath $dir if ! -e $dir;
  38                 #warn "# dir $dir";
  39         }
  40 }
  41 sub write_file {
  42         my ( $path, $content ) = @_;
  43         $path =~ s{^/+}{};
  44         create_path $path;
  45         File::Slurp::write_file $path, $content;
  46         print "$path ", -s $path, " bytes created\n";
  47 }
  48
  49 sub write_attachment {
  50         my ( $path ) = @_;
  51         my $file = "_attachemnts/$path";
  52         create_path $file;
  53         $ua->mirror( "$url/$path", $file );
  54         print "detached $file ", -s $file, " bytes\n";
  55 }
  56
  57
  58 sub unroll {
  59         my ( $tree, $path ) = @_;
  60
  61         my $ref = ref $tree;
  62         if ( $ref eq 'HASH' ) {
  63                 foreach my $child ( keys %$tree ) {
  64                         if ( $child eq '_attachments' ) {
  65                                 write_attachment $_ foreach keys %{ $tree->{$child} };
  66                         } else {
  67                                 unroll( $tree->{$child}, $path ? "$path/$child" : $child );
  68                         }
  69                 }
  70         } elsif ( $ref ) {
  71                 warn "UNSUPPORTED $path $ref ", dump( $tree );
  72                 write_file "$path.json", to_json $tree;
  73         } elsif ( $ref eq '' ) {
  74
  75                 if ( $tree =~ m[^\s*(function(.*){.*}|/\*|//|var)]is ) {
  76                         $path .= '.js';
  77                 } elsif ( $tree =~ m{<%=.*%>} ) { # couchapp template
  78                         $path .= '.html';
  79                 } else {
  80                         warn "# can't detect type of $path\n";
  81                 }
  82
  83                 write_file $path, $tree;
  84         }
  85
  86 }
  87
  88 if ( $command eq 'pull' ) {
  89
  90         warn "# get $url\n";
  91         my $response = $ua->get( $url );
  92         die $response->status_line if $response->is_error;
  93
  94         my $json = $response->decoded_content;
  95         write_file "../$database-$design.pull.js", $json;
  96
  97         unroll( from_json $json, '' );
  98
  99 } elsif ( $command eq 'push' ) {
 100
 101         my $json;
 102
 103         find({ no_chdir => 1, wanted => sub {
 104                 my $path = $File::Find::name;
 105                 return unless -f $path;
 106
 107 warn "## $path\n";
 108
 109                 $path =~ s{^\./}{};
 110
 111                 if ( $path =~ m{_attachemnts/(.+)} ) {
 112
 113                         my $filename = $1;
 114                         my $content_type = 'text/plain';
 115                         $content_type = type_from_ext($1) if $filename =~ m{\.(\w+)$};
 116
 117                         my $data = File::Slurp::read_file( $path );
 118                         $data = encode_base64( $data );
 119                         # XXX inline attachments must be single line
 120                         # XXX http://wiki.apache.org/couchdb/HTTP_Document_API
 121                         $data =~ s/[\n\r]+//gs;
 122                         $json->{_attachments}->{ $filename } = {
 123                                 content_type => $content_type,
 124                                 data         => $data,
 125                         };
 126                         return;
 127                 }
 128
 129                 my $data = File::Slurp::read_file( $path );
 130                 $path =~ s[/]['}->{']g;
 131                 $path =~ s{\.\w+$}{};
 132                 my $code = "\$json->{'$path'} = \$data;";
 133                 eval $code;
 134                 die "ERROR in $code: $@" if $@;
 135 #               warn "## json = ",dump( $json );
 136         }}, '.' );
 137
 138         if ( ! defined $json->{_id} ) {
 139                 warn "creating _id for document\n";
 140                 $json->{_id} = $$ . '-' . time();
 141         }
 142         delete( $json->{_rev} ) && warn "removing _rev from document\n";
 143
 144         print "push $database/_design/$design\n";
 145         write_file "../$database-$design.push.js", to_json $json;
 146
 147         warn "# put $url\n";
 148         my $response = $ua->request(
 149                 HTTP::Request::Common::PUT(
 150                         $url,
 151                         'Content-Type' => 'application/json',
 152                         Content => to_json $json,
 153                 )
 154         );
 155
 156         if ( $response->code == 409 ) {
 157                 warn "## update $url\n";
 158                 my $response = $ua->get( $url );
 159                 die $response->status_line if $response->is_error;
 160
 161                 my $data = from_json $response->decoded_content;
 162                 $json->{$_} = $data->{$_} foreach ( '_rev', '_id' );
 163
 164                 $response = $ua->request( HTTP::Request::Common::PUT($url, 'Content-Type' => 'application/json', Content => to_json $json ) );
 165                 die $response->status_line if $response->is_error;
 166                 warn "push updated $url\n";
 167         } else {
 168                 die $response->status_line if $response->is_error;
 169                 warn "push new $url\n";
 170         }
 171
 172 } else {
 173         die "$0: unknown command $command";
 174 }
 175