A3C/bin/ldap2model.pl

#!/usr/bin/perl
use warnings;
use strict;

=head1 NAME

schema2model.pl - convert LDAP schema file into jifty model

=head1 DESCRIPTION

Create model from ldif data

  ./bin/ldap2model.pl --model hrEduOrg --path data/all.ldif

or directly from LDAP server

  ./bin/ldap2model.pl --model inetOrgPerson
  ./bin/ldap2model.pl --model organization

which must match C<LDAP.objectClass> in C<etc/conf.yml>

With C<--debug> switch all output will go to C<STDOUT>
instead to files.

If your schema for model doesn't include some objectClasses
and you want to mixin them manually, use something like:

  ./bin/ldap2model.pl --model hrEduOrg --mixin dcObject --mixin posixAccount

=cut

use lib 'lib';

use Jifty;
use A3C::LDAP;
use Net::LDAP::Schema;
use File::Slurp;
use Data::Dump qw/dump/;
use Getopt::Long;

my ( $path, $objectClass, $debug );
my @mixin;

GetOptions(
        'model|objectClass=s', => \$objectClass,
        'mixin=s', => \@mixin,
        'path=s', => \$path,
        'debug+', => \$debug,
);

die "usage: $0 --model netOrgPerson [--path path/to/schema.ldif]\n" unless $objectClass;

my $schema;
if ( $path ) {
        $schema = Net::LDAP::Schema->new;
        $schema->parse ( $path ) or die $schema->error;
        warn "# loaded schema from $path\n";
} else {
        my $l = A3C::LDAP->new;
        $schema = $l->ldap->schema;
}

die "$objectClass objectClass not found in $path\n" unless $schema->objectclass( $objectClass );

my $model = qq/package A3C::Model::$objectClass;
use strict;
use warnings;

use Jifty::DBI::Schema;

use A3C::Record schema {

/;

my $methods;
my $create;
my $columns;

sub model_columns {
        my $objectClass = shift;
        my $model;
        warn "Creating columns for model $objectClass\n";

        $methods .= qq/\n=head2 $objectClass\n=cut\n\n/;

        sub entry {
                my ( $e, $add ) = @_;
                my $name = $_->{name} || die "no name?";
                if ( $columns->{$name} ) {
                        warn "WARNING: column $name found again, skipping...\n";
                        return '';
                }
                $methods .= qq/sub $_ { \$_[0]->$name }\n/ foreach @{$_->{aliases}};
                my $out = qq/\tcolumn $name =>\n\t\tlabel is _('$_->{desc}')/;
#               $out .= qq/,\n\t\t# single-value/ if $_->{'single-value'};
#               $out .= qq/,\n\t\tfilters are qw(A3C::Filter::Array)/ unless $_->{'single-value'};
                $out .= qq/,\n\t\tmax_length is $_->{max_length}/ if $_->{'max_length'};
                $out .= qq/,\n\t\t$add/ if $add;
                $out .= qq/;\n\n/;
                $columns->{$name}++;
                return $out;
        }

        $model .= qq/\t# $objectClass super: / . join(' ', $schema->superclass($objectClass)). qq/\n\n/ if $schema->superclass($objectClass);

        my $must;
        map {
                warn "# $objectClass must: ",dump( $_ ),$/ if $debug;
                $must .= entry( $_, 'is mandatory' );
                $create->{$_->{name}} = $_->{'single-value'} ? $_->{name} : [ $_->{name}, $_->{desc} ];
        } $schema->must( $objectClass );
        $model .= qq/\t# $objectClass must:\n\n$must\n/ if $must;

        my $may;
        map {
                warn "# $objectClass may: ",dump( $_ ),$/ if $debug;
                $may .= entry( $_ );
        } $schema->may( $objectClass );
        $model .= qq/\t# $objectClass may:\n\n$may\n/ if $may;

        return $model;
}

$model .= model_columns( $objectClass );
$model .= model_columns( $_ ) foreach @mixin;

$methods .= qq/\n=head2 name\n\nAuto-generated human readable id for generic access to name\n\n=cut\n\nsub name { \$_[0]->id }\n/ unless $columns->{name};

$model .= qq/

};

$methods

=head ACL

We use L<A3C::DefaultACL> for access control

=cut

use A3C::DefaultACL;

1;
/;

if ( $debug ) {
        print "##### ----- start of created model $objectClass\n\n$model\n\n#### ---- END of created model $objectClass\n";
} else {
        my $model_path = "lib/A3C/Model/$objectClass.pm";
        write_file( $model_path, $model );
        print "Created $model_path\n";
}

my $test = <<'__END_OF_TEST__';
#!/usr/bin/env perl
use warnings;
use strict;

=head1 DESCRIPTION

A basic test harness for the _objectClass_ model.

=cut

use Jifty::Test tests => 11;

# Make sure we can load the model
use_ok('A3C::Model::_objectClass_');

# Grab a system user
my $system_user = A3C::CurrentUser->superuser;
ok($system_user, "Found a system user");

# Try testing a create
my $o = A3C::Model::_objectClass_->new(current_user => $system_user);
my ($id) = $o->create(
_create_1_);
ok($id, "_objectClass_ create returned success");
ok($o->id, "New _objectClass_ has valid id set");
is($o->id, $id, "Create returned the right id");

# And another
$o->create(
_create_2_);
ok($o->id, "_objectClass_ create returned another value");
isnt($o->id, $id, "And it is different from the previous one");

# Searches in general
my $collection =  A3C::Model::_objectClass_Collection->new(current_user => $system_user);
$collection->unlimit;
is($collection->count, 2, "Finds two records");

# Searches in specific
$collection->limit(column => 'id', value => $o->id);
is($collection->count, 1, "Finds one record with specific id");

# Delete one of them
$o->delete;
$collection->redo_search;
is($collection->count, 0, "Deleted row is gone");

# And the other one is still there
$collection->unlimit;
is($collection->count, 1, "Still one left");
__END_OF_TEST__

$test =~ s/_objectClass_/$objectClass/gs;

foreach my $round ( 1 .. 2 ) {
        my $data;
        $data .= qq/\t\t'$_' => / . dump( $create->{$_} ) . qq/,\n/ foreach keys %$create;
        warn "$round data = $data\n" if $debug;
        $test =~ s/_create_${round}_/$data/gs;
}

if ( $debug ) {
        print "##### ----- template test\n$test\n";
} else {
        my $test_path = "t/00-model-$objectClass.t";
        write_file( $test_path, $test );
        print "Created $test_path\n";
        chmod 0755, $test_path;
}
1	dpavlin	98	#!/usr/bin/perl
2			use warnings;
3			use strict;
4
5	dpavlin	105	=head1 NAME
6	dpavlin	98
7	dpavlin	105	schema2model.pl - convert LDAP schema file into jifty model
8
9			=head1 DESCRIPTION
10
11			Create model from ldif data
12
13			./bin/ldap2model.pl --model hrEduOrg --path data/all.ldif
14
15			or directly from LDAP server
16
17			./bin/ldap2model.pl --model inetOrgPerson
18			./bin/ldap2model.pl --model organization
19
20			which must match C<LDAP.objectClass> in C<etc/conf.yml>
21
22			With C<--debug> switch all output will go to C<STDOUT>
23			instead to files.
24
25	dpavlin	114	If your schema for model doesn't include some objectClasses
26			and you want to mixin them manually, use something like:
27
28			./bin/ldap2model.pl --model hrEduOrg --mixin dcObject --mixin posixAccount
29
30	dpavlin	105	=cut
31
32	dpavlin	103	use lib 'lib';
33
34			use Jifty;
35			use A3C::LDAP;
36	dpavlin	98	use Net::LDAP::Schema;
37	dpavlin	99	use File::Slurp;
38	dpavlin	98	use Data::Dump qw/dump/;
39	dpavlin	103	use Getopt::Long;
40	dpavlin	98
41	dpavlin	105	my ( $path, $objectClass, $debug );
42	dpavlin	114	my @mixin;
43	dpavlin	98
44	dpavlin	103	GetOptions(
45			'model\|objectClass=s', => \$objectClass,
46	dpavlin	114	'mixin=s', => \@mixin,
47	dpavlin	103	'path=s', => \$path,
48	dpavlin	105	'debug+', => \$debug,
49	dpavlin	103	);
50	dpavlin	98
51	dpavlin	103	die "usage: $0 --model netOrgPerson [--path path/to/schema.ldif]\n" unless $objectClass;
52	dpavlin	98
53	dpavlin	103	my $schema;
54			if ( $path ) {
55			$schema = Net::LDAP::Schema->new;
56			$schema->parse ( $path ) or die $schema->error;
57			warn "# loaded schema from $path\n";
58			} else {
59			my $l = A3C::LDAP->new;
60			$schema = $l->ldap->schema;
61			}
62
63	dpavlin	99	die "$objectClass objectClass not found in $path\n" unless $schema->objectclass( $objectClass );
64
65			my $model = qq/package A3C::Model::$objectClass;
66			use strict;
67			use warnings;
68
69			use Jifty::DBI::Schema;
70
71			use A3C::Record schema {
72
73			/;
74
75			my $methods;
76	dpavlin	102	my $create;
77			my $columns;
78	dpavlin	99
79	dpavlin	114	sub model_columns {
80			my $objectClass = shift;
81			my $model;
82			warn "Creating columns for model $objectClass\n";
83	dpavlin	98
84	dpavlin	114	$methods .= qq/\n=head2 $objectClass\n=cut\n\n/;
85	dpavlin	98
86	dpavlin	114	sub entry {
87			my ( $e, $add ) = @_;
88			my $name = $_->{name} \|\| die "no name?";
89			if ( $columns->{$name} ) {
90			warn "WARNING: column $name found again, skipping...\n";
91			return '';
92			}
93			$methods .= qq/sub $_ { \$_[0]->$name }\n/ foreach @{$_->{aliases}};
94			my $out = qq/\tcolumn $name =>\n\t\tlabel is _('$_->{desc}')/;
95			# $out .= qq/,\n\t\t# single-value/ if $_->{'single-value'};
96			# $out .= qq/,\n\t\tfilters are qw(A3C::Filter::Array)/ unless $_->{'single-value'};
97			$out .= qq/,\n\t\tmax_length is $_->{max_length}/ if $_->{'max_length'};
98			$out .= qq/,\n\t\t$add/ if $add;
99			$out .= qq/;\n\n/;
100			$columns->{$name}++;
101			return $out;
102			}
103	dpavlin	98
104	dpavlin	114	$model .= qq/\t# $objectClass super: / . join(' ', $schema->superclass($objectClass)). qq/\n\n/ if $schema->superclass($objectClass);
105	dpavlin	102
106	dpavlin	114	my $must;
107			map {
108			warn "# $objectClass must: ",dump( $_ ),$/ if $debug;
109			$must .= entry( $_, 'is mandatory' );
110			$create->{$_->{name}} = $_->{'single-value'} ? $_->{name} : [ $_->{name}, $_->{desc} ];
111			} $schema->must( $objectClass );
112			$model .= qq/\t# $objectClass must:\n\n$must\n/ if $must;
113	dpavlin	98
114	dpavlin	114	my $may;
115			map {
116			warn "# $objectClass may: ",dump( $_ ),$/ if $debug;
117			$may .= entry( $_ );
118			} $schema->may( $objectClass );
119			$model .= qq/\t# $objectClass may:\n\n$may\n/ if $may;
120	dpavlin	98
121	dpavlin	114	return $model;
122			}
123	dpavlin	98
124	dpavlin	114	$model .= model_columns( $objectClass );
125			$model .= model_columns( $_ ) foreach @mixin;
126	dpavlin	102
127	dpavlin	114	$methods .= qq/\n=head2 name\n\nAuto-generated human readable id for generic access to name\n\n=cut\n\nsub name { \$_[0]->id }\n/ unless $columns->{name};
128
129	dpavlin	99	$model .= qq/
130
131			};
132
133			$methods
134
135	dpavlin	114	=head ACL
136
137			We use L<A3C::DefaultACL> for access control
138
139			=cut
140
141	dpavlin	99	use A3C::DefaultACL;
142
143			1;
144			/;
145
146	dpavlin	105	if ( $debug ) {
147	dpavlin	114	print "##### ----- start of created model $objectClass\n\n$model\n\n#### ---- END of created model $objectClass\n";
148	dpavlin	105	} else {
149			my $model_path = "lib/A3C/Model/$objectClass.pm";
150			write_file( $model_path, $model );
151			print "Created $model_path\n";
152			}
153	dpavlin	102
154			my $test = <<'__END_OF_TEST__';
155			#!/usr/bin/env perl
156			use warnings;
157			use strict;
158
159			=head1 DESCRIPTION
160
161			A basic test harness for the _objectClass_ model.
162
163			=cut
164
165			use Jifty::Test tests => 11;
166
167			# Make sure we can load the model
168			use_ok('A3C::Model::_objectClass_');
169
170			# Grab a system user
171			my $system_user = A3C::CurrentUser->superuser;
172			ok($system_user, "Found a system user");
173
174			# Try testing a create
175			my $o = A3C::Model::_objectClass_->new(current_user => $system_user);
176			my ($id) = $o->create(
177			_create_1_);
178			ok($id, "_objectClass_ create returned success");
179			ok($o->id, "New _objectClass_ has valid id set");
180			is($o->id, $id, "Create returned the right id");
181
182			# And another
183			$o->create(
184			_create_2_);
185			ok($o->id, "_objectClass_ create returned another value");
186			isnt($o->id, $id, "And it is different from the previous one");
187
188			# Searches in general
189			my $collection = A3C::Model::_objectClass_Collection->new(current_user => $system_user);
190			$collection->unlimit;
191			is($collection->count, 2, "Finds two records");
192
193			# Searches in specific
194			$collection->limit(column => 'id', value => $o->id);
195			is($collection->count, 1, "Finds one record with specific id");
196
197			# Delete one of them
198			$o->delete;
199			$collection->redo_search;
200			is($collection->count, 0, "Deleted row is gone");
201
202			# And the other one is still there
203			$collection->unlimit;
204			is($collection->count, 1, "Still one left");
205			__END_OF_TEST__
206
207			$test =~ s/_objectClass_/$objectClass/gs;
208
209			foreach my $round ( 1 .. 2 ) {
210			my $data;
211	dpavlin	108	$data .= qq/\t\t'$_' => / . dump( $create->{$_} ) . qq/,\n/ foreach keys %$create;
212	dpavlin	105	warn "$round data = $data\n" if $debug;
213	dpavlin	102	$test =~ s/_create_${round}_/$data/gs;
214			}
215
216	dpavlin	105	if ( $debug ) {
217			print "##### ----- template test\n$test\n";
218			} else {
219			my $test_path = "t/00-model-$objectClass.t";
220			write_file( $test_path, $test );
221			print "Created $test_path\n";
222			chmod 0755, $test_path;
223			}