├── README
├── t
├── dahut.svg
├── 00-load.t
├── 05-pod.t
├── 10-pod-coverage.t
└── 15-deploy.t
├── TODO
├── Makefile.PL
├── MANIFEST.SKIP
├── MANIFEST
├── example.pl
└── lib
└── CouchDB
├── Deploy
└── Process.pm
└── Deploy.pm
/README:
--------------------------------------------------------------------------------
1 |
2 | CouchDB::Deploy -- A simple way of deploying CouchDB projects
3 |
--------------------------------------------------------------------------------
/t/dahut.svg:
--------------------------------------------------------------------------------
1 |
--------------------------------------------------------------------------------
/t/00-load.t:
--------------------------------------------------------------------------------
1 | #!/usr/bin/perl
2 |
3 | use strict;
4 | use warnings;
5 | use Test::More tests => 2;
6 |
7 | BEGIN {
8 | use_ok('CouchDB::Deploy::Process');
9 | use_ok('CouchDB::Deploy');
10 | }
11 |
--------------------------------------------------------------------------------
/t/05-pod.t:
--------------------------------------------------------------------------------
1 | #!/usr/bin/perl
2 |
3 | use strict;
4 | use warnings;
5 | use Test::More;
6 |
7 | eval "use Test::Pod 1.14";
8 | plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
9 | all_pod_files_ok();
10 |
--------------------------------------------------------------------------------
/TODO:
--------------------------------------------------------------------------------
1 |
2 | For 0.02:
3 | X add a base64 bit of sugar so people can inline text
4 | - increase test coverage
5 |
6 | For 0.03:
7 | - add a 'bulk' call for bulk documents
8 | - add CouchDB::View support for views written in Perl
9 |
10 |
--------------------------------------------------------------------------------
/t/10-pod-coverage.t:
--------------------------------------------------------------------------------
1 | #!/usr/bin/perl
2 |
3 | use strict;
4 | use warnings;
5 | use Test::More;
6 |
7 | eval "use Test::Pod::Coverage 1.04";
8 | plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
9 | all_pod_coverage_ok();
10 |
--------------------------------------------------------------------------------
/Makefile.PL:
--------------------------------------------------------------------------------
1 | use inc::Module::Install 0.64;
2 |
3 | name 'CouchDB-Deploy';
4 |
5 | perl_version '5.006';
6 | license 'perl';
7 | all_from 'lib/CouchDB/Deploy.pm';
8 |
9 | requires 'Sub::Exporter';
10 | requires 'CouchDB::Client';
11 | requires 'Data::Compare';
12 | requires 'File::Spec';
13 |
14 | WriteAll;
15 |
--------------------------------------------------------------------------------
/MANIFEST.SKIP:
--------------------------------------------------------------------------------
1 | \.sw.$
2 | \bRCS\b
3 | \bCVS\b
4 | ^_build/
5 | ^Build$
6 | ^blib/
7 | ^Makefile$
8 | ^MANIFEST.bak$
9 | ^MANIFEST.SKIP$
10 | ^pm_to_blib$
11 | ^Makefile.[a-z]+$
12 | \.cvsignore$
13 | \B\.svn\b
14 | ^diff
15 | ^patch
16 | \.patch$
17 | ^log$
18 | ^blibdirs$
19 | \.tar\.gz$
20 |
21 | cover_db
22 | CouchDB-Deploy.tmproj
23 | example.pl
24 |
--------------------------------------------------------------------------------
/MANIFEST:
--------------------------------------------------------------------------------
1 | inc/Module/Install.pm
2 | inc/Module/Install/Base.pm
3 | inc/Module/Install/Can.pm
4 | inc/Module/Install/Fetch.pm
5 | inc/Module/Install/Makefile.pm
6 | inc/Module/Install/Metadata.pm
7 | inc/Module/Install/Win32.pm
8 | inc/Module/Install/WriteAll.pm
9 | lib/CouchDB/Deploy.pm
10 | lib/CouchDB/Deploy/Process.pm
11 | Makefile.PL
12 | MANIFEST This list of files
13 | META.yml
14 | README
15 | t/00-load.t
16 | t/05-pod.t
17 | t/10-pod-coverage.t
18 | t/15-deploy.t
19 | t/dahut.svg
20 | TODO
21 |
--------------------------------------------------------------------------------
/example.pl:
--------------------------------------------------------------------------------
1 |
2 | use CouchDB::Deploy;
3 |
4 | # need to automatically parse options to know what the server is
5 | # don't use a cache file, just talk to the server and figure out if we need to change things or not
6 | # we probably want to generate interfaces out of this, so it shouldn't have the use CouchDB::Deploy
7 | # but rather be loaded and eval'ed in different contexts producing different results
8 |
9 | db 'robin-test-db/', containing {
10 | doc {
11 | _id => 'foo',
12 | key => 'value',
13 | _attachments => {
14 | 'foo.txt' => {
15 | content_type => 'text/plain',
16 | data => 'RGFodXRzIEZvciBXb3JsZCBEb21pbmF0aW9uXCE=',
17 | },
18 | 'bar.svg' => {
19 | content_type => 'image/svg+xml',
20 | data => file 'dahut.svg',
21 | },
22 | },
23 | };
24 | design {
25 | _id => '_design/dahuts',
26 | language => 'javascript',
27 | views => {
28 | 'all' => {
29 | map => "function(doc) { if (doc.type == 'dahut') emit(null, doc) }",
30 | },
31 | },
32 | };
33 | };
34 |
35 |
36 |
--------------------------------------------------------------------------------
/t/15-deploy.t:
--------------------------------------------------------------------------------
1 | #!/usr/bin/perl
2 |
3 | use strict;
4 | use warnings;
5 | use Test::More;
6 | use Data::Dumper;
7 |
8 | use CouchDB::Deploy;
9 | use CouchDB::Client qw();
10 |
11 | my $SERVER = $ARGV[0] || $ENV{COUCHDB_DEPLOY_SERVER} || 'http://localhost:5984/';
12 | my $C = CouchDB::Client->new(uri => $SERVER);
13 |
14 | if($C->testConnection) {
15 | plan tests => 31;
16 | }
17 | else {
18 | plan skip_all => 'Could not connect to CouchDB, skipping.';
19 | warn < $docName1,
38 | type => 'dahut',
39 | _attachments => {
40 | 'foo.txt' => {
41 | content_type => 'text/plain',
42 | data => 'RGFodXRzIEZvciBXb3JsZCBEb21pbmF0aW9uIQ==',
43 | },
44 | 'bar.svg' => {
45 | content_type => 'image/svg+xml',
46 | data => file 'dahut.svg',
47 | },
48 | },
49 | };
50 | design {
51 | _id => $ddName1,
52 | language => 'javascript',
53 | views => {
54 | 'all' => {
55 | map => "function(doc) { if (doc.type == 'dahut') emit(null, doc) }",
56 | },
57 | },
58 | };
59 | };
60 | }
61 |
62 | ### --- FIRST CALL
63 | eval { deploy(); };
64 | ok not($@), 'deploy did not explode';
65 |
66 | ok $C->dbExists($dbName), 'DB was created';
67 | my $DB = $C->newDB($dbName);
68 |
69 | ok @{$DB->listDocs} == 2, 'DB contains two docs (the doc and the design doc)';
70 | ok $DB->docExists($docName1), 'DB contains the right doc name';
71 | my $DOC = $DB->newDoc($docName1)->retrieve;
72 | ok $DOC->data->{type} eq 'dahut', 'Good doc content';
73 | ok keys %{$DOC->attachments} == 2, 'Good number of attachments';
74 | ok $DOC->fetchAttachment('foo.txt') eq 'Dahuts For World Domination!', 'Attach 1 good content';
75 | ok $DOC->fetchAttachment('bar.svg') =~ m/svg/, 'Attach 2 good content';
76 |
77 | ok @{$DB->listDesignDocs} == 1, 'DB contains one design doc';
78 | ok $DB->designDocExists($ddName1), 'DB contains the right design doc name';
79 | my $DD = $DB->newDesignDoc($ddName1)->retrieve;
80 | ok $DD->views->{all}, 'Good design doc content';
81 |
82 | ### --- SECOND CALL
83 |
84 | my $docRev = $DOC->rev;
85 | my $ddRev = $DD->rev;
86 | eval { deploy(); };
87 | ok not($@), 'deploy did not explode the second time';
88 | ok $C->dbExists($dbName), 'DB still there';
89 | ok @{$DB->listDocs} == 2, 'DB still contains two docs';
90 | ok $DB->docExists($docName1), 'DB still contains the right doc name';
91 | ok @{$DB->listDesignDocs} == 1, 'DB still contains one design doc';
92 | ok $DB->designDocExists($ddName1), 'DB still contains the right design doc name';
93 | $DOC->retrieve;
94 | $DD->retrieve;
95 | ok $docRev == $DOC->rev, 'Doc rev has not changed';
96 | ok $ddRev == $DD->rev, 'Design Doc rev has not changed';
97 |
98 |
99 | ### --- EXTRA DOC AND DESIGN
100 |
101 | eval {
102 | db $dbName, containing {
103 | doc {
104 | _id => $docName2,
105 | type => 'dahut',
106 | };
107 | design {
108 | _id => $ddName2,
109 | language => 'javascript',
110 | views => {},
111 | };
112 | };
113 | };
114 | ok not($@), 'deploy of more did not explode';
115 |
116 | ok $C->dbExists($dbName), 'DB still still there';
117 | ok @{$DB->listDocs} == 4, 'DB now contains four docs';
118 | ok $DB->docExists($docName2), 'DB contains new doc';
119 | ok @{$DB->listDesignDocs} == 2, 'DB now contains two design doc';
120 | ok $DB->designDocExists($ddName2), 'DB contains new design doc';
121 | $DOC->retrieve;
122 | $DD->retrieve;
123 | ok $docRev == $DOC->rev, 'Old Doc rev has not changed';
124 | ok $ddRev == $DD->rev, 'Old Design Doc rev has not changed';
125 |
126 |
127 | ### --- update a bit
128 | my $DOC2 = $DB->newDoc($docName2)->retrieve;
129 | my $doc2Rev = $DOC2->rev;
130 | eval {
131 | db $dbName, containing {
132 | doc {
133 | _id => $docName2,
134 | type => 'dahut',
135 | more => 'see elsewhere',
136 | };
137 | };
138 | };
139 | ok not($@), 'deploy of more did not explode';
140 | ok @{$DB->listDocs} == 4, 'DB still contains four docs';
141 | ok $DB->docExists($docName2), 'DB contains doc 2';
142 | $DOC2->retrieve;
143 | ok $doc2Rev != $DOC2->rev, 'Doc rev has changed';
144 |
145 |
146 |
147 | ### --- THE CLEANUP AT THE END
148 |
149 | eval {
150 | $DD->delete;
151 | $DOC->delete;
152 | $DB->delete;
153 | };
154 | warn "\n\nSmall cleanup problem: $@\n\n" if $@;
155 |
--------------------------------------------------------------------------------
/lib/CouchDB/Deploy/Process.pm:
--------------------------------------------------------------------------------
1 |
2 | package CouchDB::Deploy::Process;
3 |
4 | use strict;
5 | use warnings;
6 |
7 | our $VERSION = $CouchDB::Deploy::VERSION;
8 |
9 | use Carp qw(confess);
10 | use CouchDB::Client;
11 | use File::Spec;
12 | use Data::Compare qw(Compare);
13 | *_SAME = \&Compare;
14 |
15 | sub new {
16 | my $class = shift;
17 | my $server = shift;
18 | return bless {
19 | server => $server,
20 | client => CouchDB::Client->new(uri => $server),
21 | }, $class;
22 | }
23 |
24 | sub createDBUnlessExists {
25 | my $self = shift;
26 | my $dbName = shift;
27 |
28 | if (not $self->{client}->dbExists($dbName)) {
29 | $self->{db} = $self->{client}->newDB($dbName)->create();
30 | return 1;
31 | }
32 | else {
33 | $self->{db} = $self->{client}->newDB($dbName);
34 | return 0;
35 | }
36 | }
37 |
38 | sub addDocumentUnlessExistsOrSame {
39 | my $self = shift;
40 | my $id = shift;
41 | my $data = shift || {};
42 | my $newAttach = shift || {};
43 |
44 | my $db = $self->{db};
45 | if (not $db->docExists($id)) {
46 | $db->newDoc($id, undef, $data, $newAttach)->create();
47 | return 1;
48 | }
49 | else {
50 | my $doc = $db->newDoc($id)->retrieve();
51 | my $content = $doc->data;
52 | my $origAttach = $doc->attachments;
53 | if (keys %$origAttach and keys %$newAttach) {
54 | # compare attachments only if the rest isn't already different
55 | if (_SAME($content, $data)) {
56 | # the length is not the same, the names are not the same, or the content types are not the same
57 | if (
58 | scalar(keys(%$origAttach)) != scalar(keys(%$newAttach)) or
59 | grep({ not exists $origAttach->{$_} } keys %$newAttach) or
60 | grep({ $origAttach->{$_}->{content_type} ne $newAttach->{$_}->{content_type} } keys %$newAttach)
61 | ) {
62 | return _UPDATE($doc, $data, $newAttach);
63 | }
64 | # we have to fall back to comparing content
65 | else {
66 | for my $att (keys %$newAttach) {
67 | my $b64 = $newAttach->{$att}->{data};
68 | if ($b64 ne $doc->toBase64($doc->fetchAttachment($att))) {
69 | return _UPDATE($doc, $data, $newAttach);
70 | }
71 | }
72 | }
73 | }
74 | else {
75 | return _UPDATE($doc, $data, $newAttach);
76 | }
77 | }
78 | else {
79 | if (not _SAME($content, $data)) {
80 | return _UPDATE($doc, $data);
81 | }
82 | }
83 | }
84 | return 0;
85 | }
86 |
87 | sub _UPDATE {
88 | my ($doc, $data, $newAttach) = @_;
89 | $doc->attachments($newAttach);
90 | $doc->data($data);
91 | $doc->update();
92 | return 2;
93 | }
94 |
95 | sub addDesignDocUnlessExistsOrSame {
96 | my $self = shift;
97 | my $id = shift;
98 | my $data = shift;
99 |
100 | my $db = $self->{db};
101 | if (not $db->designDocExists($id)) {
102 | $db->newDesignDoc($id, undef, $data)->create();
103 | return 1;
104 | }
105 | else {
106 | my $dd = $db->newDesignDoc($id)->retrieve();
107 | if (not _SAME($dd->data, $data)) {
108 | $dd->data($data);
109 | $dd->update();
110 | return 2;
111 | }
112 | return 0;
113 | }
114 | }
115 |
116 | sub getFile {
117 | my $self = shift;
118 | my $file = shift;
119 |
120 | $file = File::Spec->rel2abs(
121 | $file,
122 | File::Spec->rel2abs(
123 | File::Spec->catpath( (File::Spec->splitpath($0))[0,1], '' )
124 | )
125 | );
126 | open my $F, "<", $file or die "Can't open file: $file";
127 | my $content = do { local $/ = undef; <$F> };
128 | close $F;
129 | return CouchDB::Client::Doc->toBase64($content);
130 | }
131 |
132 | 1;
133 |
134 | =pod
135 |
136 | =head1 NAME
137 |
138 | CouchDB::Deploy::Process - The default processor for deploying to CouchDB
139 |
140 | =head1 SYNOPSIS
141 |
142 | use CouchDB::Deploy;
143 | ...
144 |
145 | =head1 DESCRIPTION
146 |
147 | This module does the actual dirty job of deploying to CouchDB. Other backends could
148 | replace it (though that's not supported yet) and it can be used by other frontends.
149 |
150 | =head1 METHODS
151 |
152 | =over 8
153 |
154 | =item new $SERVER
155 |
156 | Constructor. Expects to be passed the server to which to deploy.
157 |
158 | =item createDBUnlessExists $NAME
159 |
160 | Creates the DB with the given name, or skips it if it already exists. Returns true
161 | if it did do something.
162 |
163 | =item addDocumentUnlessExistsOrSame $ID, $DATA?, $ATTACH?
164 |
165 | Creates the document with the given ID and optional data and attachments. If the
166 | document exists it will do its best to find out if the version in the database is
167 | the same as the current one (including attachments). If it is the same it will be
168 | skipped, otherwise it will be updated. On creation it returns 1, on update 2, and
169 | if nothing was done 0.
170 |
171 | =item addDesignDocUnlessExistsOrSame $ID, $DATA
172 |
173 | Creates the design doc with the given ID and data. On creation it returns 1,
174 | on update 2, and if nothing was done 0.
175 |
176 | =item getFile $PATH
177 |
178 | Returns the content of the file in a form suitable for usage in CouchDB attachments.
179 | Dies if it can't find the file.
180 |
181 | =back
182 |
183 | =head1 AUTHOR
184 |
185 | Robin Berjon,
186 |
187 | =head1 BUGS
188 |
189 | Please report any bugs or feature requests to bug-couchdb-deploy at rt.cpan.org, or through the
190 | web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CouchDB-Deploy.
191 |
192 | =head1 COPYRIGHT & LICENSE
193 |
194 | Copyright 2008 Robin Berjon, all rights reserved.
195 |
196 | This library is free software; you can redistribute it and/or modify it under the same terms as
197 | Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may
198 | have available.
199 |
200 | =cut
201 |
202 |
--------------------------------------------------------------------------------
/lib/CouchDB/Deploy.pm:
--------------------------------------------------------------------------------
1 |
2 | package CouchDB::Deploy;
3 |
4 | use strict;
5 | use warnings;
6 |
7 | our $VERSION = '0.04';
8 |
9 | use CouchDB::Client;
10 | use CouchDB::Deploy::Process;
11 | use Carp qw(confess);
12 | use Sub::Exporter -setup => {
13 | exports => [
14 | db => \&_build_db,
15 | containing => \&_build_containing,
16 | doc => \&_build_doc,
17 | design => \&_build_design,
18 | file => \&_build_file,
19 | base64 => \&_build_base64,
20 | ],
21 | groups => {
22 | default => [qw(db containing doc design file base64)],
23 | },
24 | };
25 |
26 | my $p;
27 | BEGIN {
28 | my $server = $ARGV[0] || $ENV{COUCHDB_DEPLOY_SERVER} || 'http://localhost:5984/';
29 | confess "No server provided." unless $server;
30 | $p = CouchDB::Deploy::Process->new($server);
31 | }
32 |
33 | sub _build_db {
34 | return sub ($$) {
35 | my ($db, $sub) = @_;
36 | $p->createDBUnlessExists($db);
37 | $sub->();
38 | };
39 | }
40 |
41 | sub _build_containing { # syntax sugar
42 | return sub (&) {
43 | my $sub = shift;
44 | return $sub;
45 | };
46 | }
47 |
48 | sub _build_doc {
49 | return sub (&) {
50 | my $sub = shift;
51 | my %data = $sub->();
52 | my $id = delete($data{_id}) || confess "Document requires an '_id' field.";
53 | confess "Document must not have a '_rev' field." if $data{_rev};
54 | my $att = delete($data{_attachments}) || {};
55 | $p->addDocumentUnlessExistsOrSame($id, \%data, $att);
56 | };
57 | }
58 |
59 | sub _build_design {
60 | return sub (&) {
61 | my $sub = shift;
62 | my %data = $sub->();
63 | my $id = delete($data{_id}) || confess "Design document requires an '_id' field.";
64 | $id = "_design/$id" unless $id =~ m{^_design/};
65 | $p->addDesignDocUnlessExistsOrSame($id, \%data);
66 | };
67 | }
68 |
69 | sub _build_file {
70 | return sub ($) {
71 | my $file = shift;
72 | return $p->getFile($file);
73 | };
74 | }
75 |
76 | sub _build_base64 {
77 | return sub ($) {
78 | my $content = shift;
79 | return CouchDB::Client::Doc->toBase64($content);
80 | };
81 | }
82 |
83 |
84 | 1;
85 |
86 | =pod
87 |
88 | =head1 NAME
89 |
90 | CouchDB::Deploy - Simple configuration scripting to deploy CouchDB databases
91 |
92 | =head1 SYNOPSIS
93 |
94 | use CouchDB::Deploy;
95 |
96 | db 'my-test-db', containing {
97 | doc {
98 | _id => 'foo',
99 | key => 'value',
100 | _attachments => {
101 | 'foo.txt' => {
102 | content_type => 'text/plain',
103 | data => 'RGFodXRzIEZvciBXb3JsZCBEb21pbmF0aW9uXCE=',
104 | },
105 | 'bar.svg' => {
106 | content_type => 'image/svg+xml',
107 | data => file 'dahut.svg',
108 | },
109 | 'circle.html' => {
110 | content_type => 'text/html;charset=utf-8',
111 | data => base64 <Hello!
113 | EOHTML
114 | },
115 | },
116 | };
117 | design {
118 | _id => '_design/dahuts',
119 | language => 'javascript',
120 | views => {
121 | 'all' => {
122 | map => "function(doc) { if (doc.type == 'dahut') emit(null, doc) }",
123 | },
124 | },
125 | };
126 | };
127 |
128 | # then run the above as
129 |
130 | my-db-config.pl http://my.server:5984/
131 |
132 | =head1 DESCRIPTION
133 |
134 | This module attempts to help with the common issue of deploying databases and updates to
135 | database schemata in distributed development settings (which can simply be when you have
136 | your own dev box and a server to deploy to).
137 |
138 | CouchDB does not have schemata, but it does have views (in design documents) on which
139 | methods in your code are likely to rely. At times, you may also wish to have a given
140 | document in a database, say the default configuration.
141 |
142 | What this module does is:
143 |
144 | =over
145 |
146 | =item *
147 |
148 | Check that a given database exists, and create it if not
149 |
150 | =item *
151 |
152 | Check that a given document exists and has the same content as the one provided, and
153 | create or update it if not
154 |
155 | =item *
156 |
157 | Check that a given design document exists and has the same content as the one provided, and
158 | create or update it if not
159 |
160 | =item *
161 |
162 | Provide a simple helper for attachments and the specific base64 that CouchDB requires.
163 |
164 | =back
165 |
166 | Currently this is done in Perl, using simple syntax sugar but it is expected that it will
167 | be updated to also support a Config::Any approach.
168 |
169 | =head1 SYNTAX SUGAR
170 |
171 | =over 8
172 |
173 | =item db $DATABASE, containing { CONTENT }
174 |
175 | Creates a database with the given name, and adds the content, unless it exists.
176 |
177 | =item doc { CONTENT }
178 |
179 | Creates a document with that content, unless it is there and up to date. Note that currently
180 | only documents with an _id field are supported (otherwise we couldn't do the create-unless-exists
181 | logic). The content is of the exact same structure as the JSON one would post to CouchDB.
182 |
183 | =item file $PATH
184 |
185 | Reads the file at $PATH, converts it to base64, and returns that on a single line. This is a
186 | helper made to assist in creating CouchDB attachments. Note that in the current state it will
187 | read the file into memory.
188 |
189 | =item base64 $CONTENT
190 |
191 | Returns the content encoded in single-line Base 64.
192 |
193 | =item design { CONTENT }
194 |
195 | Creates a design document with those views and parameters, unless it is there and up to date.
196 | The content is of the exact same structure as the JSON one would post to CouchDB, except that
197 | if the C<_id> field does not start with C<_design/> it will be automatically added.
198 |
199 | =back
200 |
201 | =head1 AUTHOR
202 |
203 | Robin Berjon,
204 |
205 | =head1 BUGS
206 |
207 | Please report any bugs or feature requests to bug-couchdb-deploy at rt.cpan.org, or through the
208 | web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CouchDB-Deploy.
209 |
210 | =head1 COPYRIGHT & LICENSE
211 |
212 | Copyright 2008 Robin Berjon, all rights reserved.
213 |
214 | This library is free software; you can redistribute it and/or modify it under the same terms as
215 | Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may
216 | have available.
217 |
218 | =cut
219 |
--------------------------------------------------------------------------------