OpenAPI-PerlGenerator/lib/OpenAPI/PerlGenerator.pm
package OpenAPI::PerlGenerator 0.02;
use 5.020;
use Moo 2;
use Carp 'croak';
use experimental 'signatures'; # actually, they are stable but stable.pm doesn't know
use stable 'postderef';
use Mojo::Template;
use OpenAPI::PerlGenerator::Utils; # for tidy(), but we don't import that
use OpenAPI::PerlGenerator::Template;
use JSON::Pointer;
use Markdown::Pod;
=head1 NAME
OpenAPI::PerlGenerator - create Perl client SDKs from OpenAPI specs
=head1 SYNOPSIS
my $api_file = slurp( 'petshop.json' );
my $schema = JSON::PP->new()->decode( $api_file );
my @files = $gen->generate(
schema => $schema,
prefix => "My::API",
);
This module generates Perl clients for an OpenAPI spec. It generates
a class for each item in the C<< components/schemas >> section.
It generates C<< $prefix::Client::Impl >> as the implementation class of the
client and a stub C<< $prefix::Client >> class for overriding or refining
the autogenerated class.
=head1 METHODS
=head2 C<< new >>
=head3 Options
=over 4
=item * B<schema>
A data structure for the OpenAPI schema
=cut
has 'schema' => (
is => 'ro',
);
our %default_templates;
=item * B<templates>
A hashref of templates to use
=cut
has 'templates' => (
is => 'lazy',
default => sub { { %default_templates } },
);
=item * B<prefix>
The prefix for the modules to use
=cut
has 'prefix' => (
is => 'ro',
);
=item * B<tidy>
Run the resulting code through L<Perl::Tidy>.
Default is true.
=cut
has 'tidy' => (
is => 'rw',
default => 1,
);
our %default_typemap = (
string => 'Str',
number => 'Num',
integer => 'Int',
boolean => '', # a conflict between JSON::PP::Boolean and Type::Tiny
object => 'Object',
);
=item * B<typemap>
Hashref with the mapping of OpenAPI types to L<Type::Tiny> constraints.
=back
=cut
has 'typemap' => (
is => 'lazy',
default => sub { +{ %default_typemap } },
);
sub fixup_json_ref( $root, $curr=$root ) {
if( ref $curr eq 'ARRAY' ) {
for my $c ($curr->@*) {
$c = fixup_json_ref( $root, $c );
}
} elsif( ref $curr eq 'HASH' ) {
for my $k (sort keys $curr->%*) {
if( $k eq '$ref' ) {
my $ref = $curr->{$k};
$ref =~ s!^#!!;
# But we want to know its class, maybe?!
$curr = JSON::Pointer->get($root, $ref, 1);
} else {
$curr->{$k} = fixup_json_ref( $root, $curr->{ $k });
}
};
} else {
# nothing to do
}
return $curr
}
sub full_package( $self, $name, $prefix=$self->prefix ) {
return "$prefix\::$name";
}
sub filename( $self, $name, $prefix=$self->prefix ) {
return ((("lib::" . $self->full_package($name, $prefix)) =~ s!::!/!gr). '.pm');
}
sub markdown_to_pod( $self, $str ) {
state $converter = Markdown::Pod->new();
return $converter->markdown_to_pod( markdown => $str ) =~ s/\s+\z//r;
}
sub map_type( $self, $elt ) {
if( exists $elt->{anyOf}) {
# ... so we have a multi-type. Hope that it is just a type or null
return $self->map_type( $elt->{anyOf}->[0] );
} elsif( my $type = $elt->{type}) {
if( $type eq 'array' ) {
die "Array type has no subtype?!"
unless $elt->{items};
my $subtype = $self->map_type( $elt->{items} );
return "ArrayRef[$subtype]"
} elsif( exists $self->typemap->{ $type }) {
return $self->typemap->{ $type }
} else {
warn "Unknown type '$type'";
return '';
}
} else {
return
}
}
sub property_name( $self, $name ) {
if( $name !~ /\A[A-Za-z_]/ ) {
$name = "_" . $name;
}
$name =~ s!\W+!_!g;
return $name
}
sub single_line( $self, $str ) {
$str =~ s/\s+/ /gr
}
=head1 METHODS
=head2 C<< ->render( $name, $args ) >>
my $str = $gen->render('template_body', { prefix => 'My::API' } );
Render a template
=cut
sub render( $self, $name, $args ) {
my $template = $self->templates;
local $OpenAPI::PerlGenerator::Template::info = $self;
state $mt = Mojo::Template->new->vars(1)->namespace('OpenAPI::PerlGenerator::Template');
if( ! exists $template->{ $name }) {
die "Unknown template '$name'";
}
#warn "<<$name>>";
my $res = $mt->render( $template->{ $name }, $args );
if( ref $res and $res->isa('Mojo::Exception') ) {
warn "Template '$name' (" . join( ",", keys$args->%* ). ")";
die $res;
}
return $res
}
*include = *include = \&render;
=head2 << ->generate( %options ) >>
my @output = $gen->generate();
for my $package (@output) {
say "Generating " . $package->{package};
say $package->{source};
}
Generate the packages from the templates.
=cut
sub generate( $self, %options ) {
my $schema = delete $options{ schema } // $self->schema
or croak "Need a schema";
my $templates = delete $options{ templates } // $self->templates;
my $prefix = delete $options{ prefix } // $self->prefix;
my @res;
my @packages;
# Fix up the schema to resolve JSON-style refs into real refs:
$schema = fixup_json_ref( $schema );
push @res, $self->generate_schema_classes(
schema => $schema,
templates => $templates,
prefix => $prefix,
);
my $methods = $self->openapi_method_list(
schema => $schema,
);
push @res, $self->generate_client_implementation(
methods => $methods,
prefix => $prefix,
name => 'Client::Impl',
schema => $schema,
templates => $templates,
%options
);
push @res, $self->generate_client(
methods => $methods,
prefix => $prefix,
name => 'Client',
schema => $schema,
templates => $templates,
%options
);
return @res
}
sub generate_schema_classes( $self, %options ) {
my $schema = delete $options{ schema } // $self->schema;
my $templates = delete $options{ templates } // $self->templates;
my $run_perltidy = delete $options{ tidy } // $self->tidy;
$options{ prefix } //= $self->prefix;
my @res;
for my $name ( sort keys $schema->{components}->{schemas}->%*) {
my $elt = $schema->{components}->{schemas}->{$name};
$elt->{name} //= $name;
my $type = $elt->{type};
if( exists $elt->{allOf}) {
# We should synthesize the real type here instead of punting
$type = 'object';
};
my %info = (
%options,
name => $name,
type => $type,
elt => $elt,
);
if( exists $self->templates->{ $type }) {
my $filename = $self->filename( $name, $options{ prefix } );
my $content = $self->render( $type, \%info );
if( defined $content ) {
if( $run_perltidy ) {
$content = OpenAPI::PerlGenerator::Utils::tidy( $content );
}
push @res, {
filename => $filename,
package => $self->full_package($name, $options{ prefix }),
source => $content,
};
} else {
# There was an error in this template...
}
} elsif( $type eq 'string' ) {
# Don't output anything, this should likely become an Enum in the
# type checks instead
} else {
warn "No template for type '$type' ($name)";
}
};
return @res
}
sub openapi_method_list( $self, %options ) {
my $schema = delete $options{ schema } // $self->schema;
my @methods;
# Add the methods to the main class (or, also to the current class, depending
# on tree depth?!
for my $path (sort keys $schema->{paths}->%*) {
my $loc = $schema->{paths}->{$path};
for my $method (sort keys $loc->%*) {
my $elt = $loc->{$method};
my $name = $elt->{operationId} // join "_", $path, $method;
$name =~ s!\W!_!g;
my %info = (
path => $path,
name => $name,
method => $elt->{method},
http_method => $method,
elt => $elt,
);
push @methods, \%info;
}
}
return \@methods
}
sub generate_client_implementation( $self, %options ) {
my $schema = delete $options{ schema } // $self->schema;
my $methods = delete $options{ methods } // $self->openapi_method_list( schema => $schema );
$options{ prefix } //= $self->prefix;
my $content = $self->render('client_implementation',{
methods => $methods,
name => 'Client::Impl',
schema => $schema,
%options
});
return {
filename => $self->filename('Client::Impl',$options{ prefix }),
package => $self->full_package('Client::Impl',$options{ prefix }),
source => $content,
};
}
sub generate_client( $self, %options ) {
my $schema = delete $options{ schema } // $self->schema;
my $methods = delete $options{ methods } // $self->openapi_method_list( schema => $schema );
$options{ prefix } //= $self->prefix;
my $content = $self->render('client', {
methods => $methods,
name => 'Client',
schema => $schema,
%options
});
return {
filename => $self->filename('Client',$options{ prefix }),
package => $self->full_package('Client',$options{ prefix }),
source => $content,
};
}
=head2 C<< ->load_schema( %options ) >>
my $res = $gen->load_schema(
schema => $schema,
prefix => 'My::Schema',
);
Compiles the packages and installs them in the current process
with the namespace given.
=cut
sub load_schema( $self, %options ) {
$options{ packages } //= [$self->generate(
%options,
)];
my @packages = $options{ packages }->@*;
my @errors;
for my $package (@packages) {
eval $package->{source};
if( $@ ) {
push @errors, +{
name => $package->{name},
filename => $package->{filename},
message => "$@",
};
};
}
return {
errors => \@errors,
packages => \@packages,
};
}
# This stuff should go into an OpenAPI schema helper module
sub openapi_submodules( $self, $schema ) {
$schema //= $self->schema;
my $schemata = $schema->{components}->{schemas};
map { $_ => $schemata->{ $_ } } sort keys $schemata->%*
}
sub openapi_response_content_types( $self, $elt ) {
my %known;
for my $code (sort keys $elt->{responses}->%*) {
my $info = $elt->{responses}->{ $code };
for my $ct (sort keys $info->{content}->%*) {
$known{ $ct } = 1;
};
};
return sort keys %known;
}
sub openapi_http_code_match( $self, $code ) {
if( $code eq 'default' ) {
return q{};
} elsif( $code =~ /x/i ) {
(my $re = $code) =~ s/x/./gi;
return qq{=~ /$re/};
} else {
return qq{== $code};
}
}
1;
__END__
=head1 REPOSITORY
The public repository of this module is
L<https://github.com/Corion/OpenAPI-PerlGenerator>.
=head1 SUPPORT
The public support forum of this module is L<https://perlmonks.org/>.
=head1 BUG TRACKER
Please report bugs in this module via the Github bug queue at
L<https://github.com/Corion/OpenAPI-PerlGenerator/issues>
=head1 AUTHOR
Max Maischein C<corion@cpan.org>
=head1 COPYRIGHT (c)
Copyright 2024- by Max Maischein C<corion@cpan.org>.
=head1 LICENSE
This module is released under the Artistic License 2.0.
=cut