view release on metacpan or  search on metacpan

lib/Apache2/API.pm  view on Meta::CPAN

    # }
    # otherwise, the legacy approach would be:
    # {
    #     error =>
    #     {
    #         code => 404,
    #         message => q{The requested URL was not found on this server. If you entered the URL manually please check your spelling and try again.},
    #     },
    #     locale => 'en-US',
    # }
    # $self->reply( Apache2::Const::HTTP_OK, { message => "All is well" } );
    if( scalar( @_ ) == 2 )
    {
        ( $code, $ref ) = @_;
    }
    elsif( scalar( @_ ) == 1 &&
        $self->_can( $_[0] => 'code' ) && 
        $self->_can( $_[0] => 'message' ) )
    {
        my $ex = shift( @_ );
        $code = $ex->code;
        $ref = 
        {
            message => $ex->message,
            ( $ex->can( 'public_message' ) ? ( public_message => $ex->public_message ) : () ),
            ( $ex->can( 'locale' ) ? ( locale => $ex->locale ) : () ),
        };
    }
    # $self->reply({ code => Apache2::Const::HTTP_OK, message => "All is well" } );
    elsif( ref( $_[0] ) eq 'HASH' )
    {
        $ref = shift( @_ );
        $code = $ref->{code} if( length( $ref->{code} ) );
    }
    my $r    = $self->apache_request;
    my $req  = $self->request;
    my $resp = $self->response;

    # Guardrails on inputs
    if( !defined( $code ) || $code !~ /^[0-9]{3}$/ )
    {
        $resp->code( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
        $resp->rflush;
        $resp->print( $self->json->utf8->encode({ error => 'An unexpected server error occured', code => 500 }) );
        $self->error( "http code to be used '", ( $code // 'undef' ), "' is invalid. It should be only integers." );
        return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
    }
    if( ref( $ref ) ne 'HASH' )
    {
        $resp->code( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
        $resp->rflush;
        # $r->send_http_header;
        $resp->print( $self->json->utf8->encode({ error => 'An unexpected server error occured', code => 500 }) );
        $self->error( "Data provided to send is not a hash ref." );
        return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
    }

    # Resolve whether this is an error
    my $is_error = $resp->is_error( $code ) ? 1 : 0;

    # NOTE: guess_preferred_locale() -> this is used to get he most appropriate locale if not defined already so we can, in turn, get the fallback description
    my $guess_preferred_locale = sub
    {
        my $locale = shift( @_ );
        if( !defined( $locale ) )
        {
            $locale = $req->preferred_language( Apache2::API::Status->supported_languages );
        }

        if( defined( $locale ) )
        {
            # Make sure we are dealing with unix style language code
            $locale =~ tr/-/_/;
            if( length( $locale ) == 2 )
            {
                $locale = Apache2::API::Status->convert_short_lang_to_long( $locale );
            }
            # We have something weird, like maybe eng?
            elsif( $locale !~ /^[a-z]{2}_[A-Z]{2}$/ )
            {
                $locale = Apache2::API::Status->convert_short_lang_to_long( substr( $locale, 0, 2 ) );
            }
        }
        return( $locale );
    };

    # NOTE: build_rfc_error() -> private subroutine to build the modern rfc9457 error payload
    my $build_rfc_error = sub
    {
        my( $ref, $code, $msg ) = @_;
        # By now, our property 'locale' has been dealt with, so we do not have to worry about it.
        # It either exists or not
        my $locale = exists( $ref->{locale} ) ? $ref->{locale} : undef;

        # The property 'status' could exist, but be undefined, or even empty, so we check for that.
        unless( exists( $ref->{status} ) &&
                defined( $ref->{status} ) &&
                length( $ref->{status} ) )
        {
            $ref->{status} = $code;
        }
        $ref->{status} = int( $ref->{status} ) if( $ref->{status} =~ /^\d+$/ );

        # Title from caller or from HTTP status table (localized)
        unless( exists( $ref->{title} ) &&
                defined( $ref->{title} ) &&
                length( $ref->{title} // '' ) )
        {
            if( exists( $ref->{error} ) && 
                defined( $ref->{error} ) &&
                ref( $ref->{error} ) eq 'HASH' &&
                exists( $ref->{error}->{title} ) )
            {
                $ref->{title} = delete( $ref->{error}->{title} );
            }
            elsif( $locale )
            {
                $ref->{title} = Apache2::API::Status->status_message( $code => $locale );
            }
            else
            {
                $ref->{title} = Apache2::API::Status->status_message( $code );

lib/Apache2/API.pm  view on Meta::CPAN

            delete( $ref->{error}->{ $_ } ) for( qw( code status message title ) );
            delete( $ref->{error} ) if( !scalar( keys( %{$ref->{error}} ) ) );
        }

        # Set the property 'error' (extension member): string problem code if empty hash/undef
        if( !exists( $ref->{error} ) ||
            !defined( $ref->{error} ) ||
            ( !ref( $ref->{error} ) && !length( $ref->{error} // '' ) ) ||
            ( ref( $ref->{error} ) eq 'HASH' && !scalar( keys( %{$ref->{error}} ) ) ) )
        {
            delete( $ref->{error} );
            if( my $t = Apache2::API::Status->status_to_type( $code, '-' ) )
            {
                # extension member for app code
                $ref->{error} = $t;
            }
        }

        # Build 'type' URL if not provided.
        unless( exists( $ref->{type} ) &&
            defined( $ref->{type} ) &&
            length( $ref->{type} // '' ) )
        {
            if( my $host = $req->http_host )
            {
                if( my $t = Apache2::API::Status->status_to_type( $code, '-' ) )
                {
                    my $scheme = $req->is_secure ? 'https' : 'http';
                    $ref->{type} = "${scheme}://${host}/problems/${t}";
                }
            }
        }

        # Flatten legacy fields that do not belong.
        # The rfc 9457 prefers the property 'detail'.
        delete( $ref->{message} ) if( exists( $ref->{message} ) );
        # The rfc 9457 prefers the property 'status'.
        delete( $ref->{code} ) if( exists( $ref->{code} ) );
    };

    # NOTE: build_legacy_error() -> private subroutine to build the legacy error payload
    my $build_legacy_error = sub
    {
        my( $ref, $code, $msg ) = @_;
        # By now, our property 'locale' has been dealt with, so we do not have to worry about it.
        # It either exists or not
        my $locale = exists( $ref->{error}->{locale} ) ? $ref->{error}->{locale} : undef;
        # We set the property 'error' to be an HASH if not set already.
        $ref->{error} = {} unless( exists( $ref->{error} ) && ref( $ref->{error} ) eq 'HASH' );

        # The property 'code' could exist, but be undefined, or even empty, so we check for that.
        unless( exists( $ref->{error}->{code} ) &&
                defined( $ref->{error}->{code} ) &&
                length( $ref->{error}->{code} ) )
        {
            $ref->{error}->{code} = $code;
        }
        $ref->{error}->{code} = int( $ref->{error}->{code} ) if( $ref->{error}->{code} =~ /^\d+$/ );

        # We try hard to get the value for the property 'message', but if $locale is undefined, it is impossible to find out the language that was used to formulate the response.
        # So, ultimately, if we cannot find any value for the property 'message', we revert to guessing the HTTP caller's preferred language, which may, or may not be aligned with the content of other parts of the JSON response. Given that, in that s...
        if( !exists( $ref->{error}->{message} ) ||
            !defined( $ref->{error}->{message} ) ||
            !length( $ref->{error}->{message} // '' ) )
        {
            if( defined( $msg ) &&
                ( !ref( $msg ) || $self->_can_overload( $msg => "''" ) ) )
            {
                $ref->{error}->{message} = "$msg";
            }
            else
            {
                foreach my $p ( qw( message detail details ) )
                {
                    if( exists( $ref->{ $p } ) &&
                        defined( $ref->{ $p } ) &&
                        length( $ref->{ $p } ) )
                    {
                        $ref->{error}->{message} = delete( $ref->{ $p } );
                        last;
                    }
                }
            }

            # Still nothing ? Get the fallback value using 'get_http_message' either using the $locale, if defined, or the HTTP caller's preferred language
            if( !$ref->{error}->{message} )
            {
                $locale = $guess_preferred_locale->( $locale ) unless( defined( $locale ) );
                my $fallback = $locale
                    ? $resp->get_http_message( $code, $locale )
                    : $resp->get_http_message( $code );
                $ref->{error}->{message} = $fallback // 'An error occurred';
            }
        }

        # Build 'type' URL if not provided
        unless( exists( $ref->{error}->{type} ) &&
            defined( $ref->{error}->{type} ) &&
            length( $ref->{error}->{type} // '' ) )
        {
            # The user has already set the 'type' property, so we use it, and move it to our 'error' hash
            if( exists( $ref->{type} ) &&
                defined( $ref->{type} ) &&
                length( $ref->{type} ) )
            {
                $ref->{error}->{type} = delete( $ref->{type} );
            }
            elsif( my $host = $req->http_host )
            {
                if( my $t = Apache2::API::Status->status_to_type( $code ) )
                {
                    (my $slug = $t) =~ tr/_/-/;
                    my $scheme = $req->is_secure ? 'https' : 'http';
                    $ref->{error}->{type} = "${scheme}://${host}/problems/${slug}";
                }
            }
            elsif( my $t = Apache2::API::Status->status_to_type( $code ) )
            {
                $ref->{error}->{type} = $t;
            }
        }

        # Collapse top-level duplicates
        delete( $ref->{ $_ } ) for( qw( message code type error_description ) );
    };

    # NOTE: set_payload_locale() -> find out and set the 'locale' property.
    my $set_payload_locale = sub
    {
        my( $ref, $msg ) = @_;
        my $locale;
        # From message object
        # '$msg' might be undef, and the method _is_a knows how to handle it.
        if( $self->_is_a( $msg => 'Text::PO::String' ) )
        {
            $locale = $msg->locale
        }
        # Check if the Content-Language has already been set.
        elsif( my $l = $resp->headers->get( 'Content-Language' ) )
        {
            $locale = $l;
            $locale =~ tr/_/-/;
        }

        if( !defined( $locale ) &&
            exists( $ref->{error} ) &&
            ref( $ref->{error} ) eq 'HASH' )
        {