lemonldap-ng/lemonldap-ng-common/lib/Lemonldap/NG/Common/PSGI.pm

package Lemonldap::NG::Common::PSGI;

use 5.10.0;
use Mouse;
use JSON;
use Lemonldap::NG::Common::PSGI::Constants;
use Lemonldap::NG::Common::PSGI::Request;

our $VERSION = '1.9.0';

our $_json = JSON->new->allow_nonref;

has error        => ( is => 'rw', default => '' );
has languages    => ( is => 'rw', isa     => 'Str', default => 'en' );
has logLevel     => ( is => 'rw', isa     => 'Str' );
has staticPrefix => ( is => 'rw', isa     => 'Str' );
has templateDir  => ( is => 'rw', isa     => 'Str' );
has links        => ( is => 'rw', isa     => 'ArrayRef' );
has syslog => (
    is      => 'rw',
    isa     => 'Str',
    trigger => sub {
        if ( $_[0]->{syslog} ) {
            eval {
                require Sys::Syslog;
                Sys::Syslog->import(':standard');
                openlog( 'lemonldap-ng', 'ndelay,pid', $_[0]->{syslog} );
            };
            $_[0]
              ->error("Unable to use syslog with facility $_[0]->{syslog}: $@")
              if ($@);
        }
    },
);

## @method void lmLog(string mess, string level)
# Log subroutine. Print on STDERR messages if it exceeds `logLevel` value
# @param $mess Text to log
# @param $level Level (debug|info|notice|warn|error)
sub lmLog {
    my ( $self, $msg, $level ) = splice @_;
    my $levels = {
        error  => 4,
        warn   => 3,
        notice => 2,
        info   => 1,
        debug  => 0
    };
    my $l = $levels->{$level} || 1;
    return if ( ref($self) and $l < $levels->{ $self->{logLevel} } );
    print STDERR "[$level] " . ( $l ? '' : (caller)[0] . ': ' ) . " $msg\n";
}

##@method void userLog(string mess, string level)
# Log user actions on Apache logs or syslog.
# @param $mess string to log
# @param $level level of log message
sub userLog {
    my ( $self, $mess, $level ) = @_;
    if ( $self->{syslog} ) {
        $self->startSyslog();
        $level =~ s/^warn$/warning/;
        syslog( $level || 'notice', $mess );
    }
    else {
        $self->lmLog( $mess, $level );
    }
}

##@method void userInfo(string mess)
# Log non important user actions. Alias for userLog() with facility "info".
# @param $mess string to log
sub userInfo {
    my ( $self, $mess ) = @_;
    $self->userLog( $mess, 'info' );
}

##@method void userNotice(string mess)
# Log user actions like access and logout. Alias for userLog() with facility
# "notice".
# @param $mess string to log
sub userNotice {
    my ( $self, $mess ) = @_;
    $self->userLog( $mess, 'notice' );
}

##@method void userError(string mess)
# Log user errors like "bad password". Alias for userLog() with facility
# "warn".
# @param $mess string to log
sub userError {
    my ( $self, $mess ) = @_;
    $self->userLog( $mess, 'warn' );
}

# Responses methods
sub sendJSONresponse {
    my ( $self, $req, $j, %args ) = splice @_;
    $args{code} ||= 200;
    my $type = 'text/json';
    if ( ref $j ) {
        if ( $args{forceJSON} or $req->accept =~ m|application/json| ) {
            $j = $_json->encode($j);
        }
        else {

            # TODO: escape keys in hash values
            eval {
                require XML::Simple;
                $j    = XML::Simple::XMLout($j);
                $type = 'text/xml';
            };
        }
    }
    return [ $args{code}, [ 'Content-Type', $type ], [$j] ];
}

sub sendError {
    my ( $self, $req, $err, $code ) = splice @_;
    $err  ||= $req->error;
    $code ||= 500;
    $self->lmLog( "Error $code: $err", $code > 499 ? 'error' : 'notice' );
    return $self->sendJSONresponse( $req, { error => $err }, code => $code );
}

sub abort {
    my ( $self, $err ) = splice @_;
    $self->lmLog( $err, 'error' );
    return sub {
        $self->sendError( Lemonldap::NG::Common::PSGI::Request->new( $_[0] ),
            $err, 500 );
    };
}

sub _mustBeDefined {
    my $name = ( caller(1) )[3];
    $name =~ s/^.*:://;
    my $call = ( caller(1) )[0];
    my $ref = ref( $_[0] ) || $call;
    die "$name() method must be implemented (probably in $ref)";
}

sub init { 1 }

sub router { _mustBeDefined(@_) }

sub sendHtml {
    my ( $self, $req, $template ) = splice @_;
    my $htpl;
    $template = $self->templateDir . "/$template.tpl";
    return $self->sendError( $req, "Unable to read $template", 500 )
      unless ( -r $template and -f $template );
    eval {
        $self->lmLog( "Starting HTML generation using $template", 'debug' );
        require HTML::Template;
        $htpl = HTML::Template->new(
            filehandle             => IO::File->new($template),
            path                   => $self->templateDir,
            die_on_bad_params      => 1,
            die_on_missing_include => 1,
            cache                  => 0,
        );

        # TODO: replace app
        # TODO: warn if STATICPREFIX does not end with '/'
        my $sp = $self->staticPrefix;
        $sp =~ s/\/*$/\//;
        $htpl->param(
            SCRIPT_NAME         => $req->scriptname,
            STATIC_PREFIX       => $sp,
            AVAILABLE_LANGUAGES => $self->languages,
            LINKS => $self->links ? encode_json( $self->links ) : '""',
        );
    };
    if ($@) {
        return $self->sendError( $req, "Unable to load template: $@", 500 );
    }
    $self->lmLog(
        'For more performance, store the result of this as static file',
        'info' );

    # Set headers
    my $hdrs = [ 'Content-Type' => 'text/html' ];
    unless ( $self->logLevel eq 'debug' ) {
        push @$hdrs,
          ETag            => "LMNG-manager-$VERSION",
          'Cache-Control' => 'private, max-age=2592000';
    }
    $self->lmLog( "Sending $template", 'debug' );
    return [ 200, $hdrs, [ $htpl->output() ] ];
}

###############
# Main method #
###############

sub run {
    my ( $self, $args ) = splice @_;
    $self = $self->new($args) unless ref($self);
    return $self->abort( $self->error ) unless ( $self->init($args) );
    return $self->_run;
}

sub _run {
    my $self = shift;
    return sub {
        $self->router( Lemonldap::NG::Common::PSGI::Request->new( $_[0] ) );
    };
}

1;