package demo;
use strict;
use warnings;
use nginx;
use IPC::Open3;
use IO::Select;
use Symbol 'gensym';
use Config;
use POSIX qw(:sys_wait_h sigprocmask SIG_BLOCK SIG_SETMASK SIGCHLD);

# Adjust if you keep your binaries elsewhere.
my $CGI_DIR = "/usr/local/lib/cgi-bin";

sub urldecode {
    my ($s) = @_;
    $s =~ tr/+/ /;
    $s =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
    return $s;
}

sub _get_param {
    my ( $qs, $name ) = @_;
    return $qs =~ /(?:^|&)\Q$name\E=([^&]*)/ ? urldecode($1) : undef;
}

sub _first_line_trimmed {
    my ($s) = @_;
    $s = '' unless defined $s;

    # Normalize newlines, take ONLY the first line (game expects a single line)
    $s =~ s/\r\n/\n/g;
    $s =~ s/\r/\n/g;
    $s =~ s/\n.*\z//s;    # keep up to first newline
    $s =~ s/^\s+//;       # trim leading ws
    $s =~ s/\s+\z//;      # trim trailing ws (incl. newline)
    return $s;
}

# Turn $? into a descriptive string.
sub _status_line {
    my ($code) = @_;
    if ( $code == -1 ) {
        my $errno  = 0 + $!;
        my $errstr = "$!";
        return sprintf "Failed to run child (fork/exec error): errno=%d (%s)",
          $errno, $errstr;
    }
    if ( $code & 127 ) {
        my $sig   = ( $code & 127 );
        my @names = split ' ', $Config{sig_name} // '';
        my $name  = $names[$sig] // '';
        my $core  = ( $code & 128 ) ? 'yes'         : 'no';
        my $label = $name           ? " (SIG$name)" : '';
        return sprintf "Terminated by signal %d%s, core=%s", $sig, $label,
          $core;
    }
    my $exit = ( $code >> 8 );
    return $exit == 0 ? "Exit 0 (ok)" : "Exit $exit";
}

sub run {
    my $r = shift;

    # If there's a request body, ask nginx to read it first and call post().
    # The ENV guard prevents recursion when post() re-enters run().
    unless ( $ENV{NGX_PERL_POST} ) {
        if ( $r->has_request_body( \&post ) ) {
            return OK;
        }
    }

    # Parse query string
    my $qs   = $r->args // '';
    my $demo = _get_param( $qs, 'demo' );
    my $play = _get_param( $qs, 'play' );  # optional; overrides body if present

    unless ( defined $demo && length $demo ) {
        $r->status(400);
        $r->send_http_header("text/plain; charset=utf-8");
        $r->print("Missing param: demo\n");
        return OK;
    }

    # Minimal safety: restrict demo to simple names to avoid traversal
    # Yes, commenting out this is intended.
    #if ( $demo !~ /\A[0-9A-Za-z._-]+\z/ ) {
    #	 $r->send_http_header("text/plain; charset=utf-8");
    #	 print "Bad demo name\n";
    #	 return OK;
    #}

    my $target = "$CGI_DIR/$demo";
    unless ( -x $target ) {
        $r->status(404);
        $r->send_http_header("text/plain; charset=utf-8");
        $r->print("no such demo: $demo\n");
        return OK;
    }

    # Read request body (raw)
    my $body = $r->request_body;    # may be undef
    if ( !defined $body ) {

        # If nginx wrote the body to a temp file, read it.
        my $f = $r->request_body_file;    # may be undef
        if ( $f && open my $fh, '<', $f ) {
            binmode $fh;
            local $/;
            $body = <$fh>;
            close $fh;
            unlink $f;                    # optional cleanup
        }
        else {
            $body = '';
        }
    }

    # Try to avoid proxy buffering
    eval { $r->header_out( "X-Accel-Buffering", "no" ); };
    eval { $r->header_out( "Cache-Control",     "no-store" ); };
    $r->send_http_header("text/plain; charset=utf-8");

    # Block SIGCHLD so nginx's global reaper can't steal our child's status.
    my $oldmask = POSIX::SigSet->new;
    sigprocmask( SIG_BLOCK, POSIX::SigSet->new(SIGCHLD), $oldmask );

    # Spawn child
    my $err = gensym;
    my ( $CH_IN, $CH_OUT );
    my ( $pid,   $open3_err );
    {
        local $@;
        $pid       = eval { open3( $CH_IN, $CH_OUT, $err, $target ) };
        $open3_err = $@;
    }
    if ( $open3_err ne '' ) {
        my $errno  = 0 + $!;
        my $errstr = "$!";
        sigprocmask( SIG_SETMASK, $oldmask );    # restore on error
        $r->print(
            sprintf "Failed to run child (fork/exec error): errno=%d (%s)\n",
            $errno, $errstr );
        $r->print("[stderr] open3 error: $open3_err\n");
        return OK;
    }

    binmode( $CH_IN,  ':raw' );
    binmode( $CH_OUT, ':raw' );
    binmode( $err,    ':raw' );

    # Enable autoflush on child's stdin so print writes flush immediately.
    { my $old = select($CH_IN); local $| = 1; select($old); }

    # If ?play=... is present, send exactly one trimmed line + newline.
    # Otherwise, send the request body verbatim as a binary blob.
    if ( defined $play ) {
        my $line = _first_line_trimmed($play);
        if ( length $line ) {
            print {$CH_IN} $line, "\n";
        }
    }
    else {
        if ( defined $body && length $body ) {
            my $off = 0;
            while ( $off < length($body) ) {
                my $w = syswrite( $CH_IN, $body, length($body) - $off, $off );
                last unless defined $w;
                $off += $w;
            }

            # Ensure binary payload is newline terminated
            # to trigger our good old gets(3).
            if ( substr( $body, -1, 1 ) ne "\n" ) {
                print {$CH_IN} "\n";
            }
        }
    }
    close $CH_IN;    # signal EOF

    # Collect stdout + stderr fully so we can print status FIRST
    my $sel     = IO::Select->new( $CH_OUT, $err );
    my $out_buf = '';
    my $err_buf = '';

    while ( $sel->count ) {
        for my $fh ( $sel->can_read(10) ) {
            my $buf = '';
            my $n   = sysread( $fh, $buf, 8192 );
            if ( defined $n && $n > 0 ) {
                if   ( $fh == $CH_OUT ) { $out_buf .= $buf; }
                else                    { $err_buf .= $buf; }
            }
            else {
                $sel->remove($fh);
                close $fh;
            }
        }

        # If child already exited and pipes are drained, loop ends naturally.
    }

    # Reap child and compute status, ignore ECHILD.
    my $wp = waitpid( $pid, 0 );
    sigprocmask( SIG_SETMASK, $oldmask );    # restore original signal mask
    my $status_line = '';
    if ( !( $wp == -1 && $!{ECHILD} ) ) {
        my $desc = _status_line($?);
        $status_line = $desc unless $desc =~ /^Exit 0\b/;
    }

    # Print: status first (only on failure),
    # then stdout,
    # then tagged stderr (line-prefix)
    $r->print( $status_line, "\n" ) if length $status_line;
    if ( length $out_buf ) {
        $r->print($out_buf);
    }
    if ( length $err_buf ) {
        $err_buf =~ s/^/[stderr] /mg;
        $r->print($err_buf);
    }

    return OK;
}

sub post {
    my $r = shift;
    local $ENV{NGX_PERL_POST} = 1;
    return run($r);
}

1;
__END__
