### ----------------------------------------------------
### -- Cro::RPC::JSON
### -- Licenses: Artistic-2.0
### -- Authors: Vadim Belman <vrurg@lflat.org>
### -- File: lib/Cro/RPC/JSON.rakumod
### ----------------------------------------------------
### -- Chunk 2 of 2
response.status = .http-code;
        }
        default {
            $response.status = 500;
        }
    };
    react {
        whenever $pipeline.transformer(supply { emit $request }) -> $msg {
            use JSON::Marshal;
            $response.remove-header('Content-Type');
            $response.append-header('Content-Type', q[application/json; charset=utf-8]);
            $response.set-body($msg.json-body);
            $response.status = 200;
        }
    }
}

multi sub json-rpc( &block,
                    Bool :ws(:web-socket(:$websocket)) where so *,
                    :&async )
{
    my $request = request;
    web-socket -> $in, $close {
        my %hparams = :$close, :protocol<WebSocket>, :$request;
        with &async {
            %hparams<async> = Supply(&async( $close ));
        }
        my Cro::Transform $pipeline =
            Cro.compose(label => "WebSocket JSON-RPC Handler",
                        Cro::RPC::JSON::RequestParser::WebSocket.new(:$request),
                        Cro::RPC::JSON::Handler.new(&block, |%hparams),
                        Cro::RPC::JSON::ResponseSerializer::WebSocket.new(:$request),
                );
        $pipeline.transformer($in)
    }
}

multi sub json-rpc ( Any:D $obj, Bool :ws(:web-socket($websocket)) ) {
    my sub obj-handler ( Supply:D $in, Promise $close? ) {
        supply {

            my sub call-phaser-methods( Str:D $mod, |c ) {
                for json-rpc-adhoc-methods($obj, $mod) -> &meth {
                    $obj.&meth: |c
                }
            }

            whenever $in -> $req {
                my $*CRO-JRPC-REQUEST = $req;
                my $*CRO-ROUTER-REQUEST = $req.request;
                my $*CRO-JRPC-PROTOCOL = $websocket ?? 'WebSocket' !! 'HTTP';
                my $*CRO-JRPC-ASYNC = False;

                my $method = json-rpc-find-method($obj, $req.method);
                unless $method {
                    $req.respond:
                        exception => X::Cro::RPC::JSON::MethodNotFound.new(
                            msg => "JSON-RPC method " ~ $req.method ~ " is not implemented by " ~ $obj.^name,
                            data => %( method => $req.method),
                            );
                    next
                }

                my $req-auth = $req.request.auth;
                # If method doesn't have auth set then pick its class' default
                my $meth-auth = $method.json-rpc-auth // json-rpc-auth($obj);
                # Only authorize if there is auth object for either method or its class.
                with $meth-auth {
                    my $authorized = False;
                    if $req-auth.defined && $req-auth ~~ Cro::RPC::JSON::Auth {
                        $authorized = $req-auth.json-rpc-authorize($meth-auth);
                    }
                    unless $authorized {
                        $req.respond:
                            exception => X::Cro::RPC::JSON::MethodNotFound.new(
                                msg => "Unauthorized access to method '" ~ $req.method ~ "'",
                                data => %( method => $req.method ),
                                );
                        next
                    }
                }

                # === Kind of binding of parameters to the signature ===
                my $signature = $method.signature;
                my @sig-params := $signature.params;
                my $raw-args := $req.has-params && $req.params.defined ?? $req.params !! Empty;
                my $arg-count = $raw-args.elems;
                my $count-with-self = $arg-count + 1; # Remember about invocator argument

                if $raw-args ~~ Positional
                   && ($signature.count < $count-with-self
                       || $signature.arity > $count-with-self)
                {
                    X::Cro::RPC::JSON::InvalidParams.new(
                            msg => "Incorrect number of parameters in call to method '" ~ $req.method ~ "'",
                            data => {
                                :$arg-count,
                                method-accepts => $signature.count,
                                method-expects => $signature.arity,
                            }
                        ).throw
                }

                # Collect all positional and named parameters of a method
                my @sig-pos;
                my %sig-named;
                my $slurpies = 0;

                for @sig-params[1..*] -> $p {
                    last if $p.capture;
                    if $p.slurpy {
                        last if ++$slurpies >= 2;
                        next;
                    }
                    elsif $p.positional {
                        @sig-pos.push: $p;
                    }
                    else {
                        %sig-named{$_} = $p for $p.named_names;
                    }
                }

                my sub maybe-unmarshal($arg, \type) {
                    ($arg ~~ Positional | Associative) && (type.WHAT !=== Any)
                        ?? unmarshal($arg, type.WHAT)
                        !! $arg
                }

                # Build method arguments. The resulting args will all be either positional or nameds. No mixture is
                # allowed because there is no way to represent it in JSON
                my (@arg-pos, %arg-named);
                if +@sig-pos || $raw-args ~~ Positional {
                    # First check if the method expects only a request object
                    if +@sig-pos == 1 && @sig-pos[0].type ~~ Cro::RPC::JSON::Request {
                        @arg-pos.push: $req;
                    }
                    else {
                        my $i = 0;
                        # A single hash object must be treated as a single argument.
                        my @arg-list := $raw-args ~~ Associative ?? ($raw-args,) !! $raw-args.List;
                        while $i < +@sig-pos {
                            my $param := @sig-pos[$i];
                            my $arg = @arg-list[$i];
                            @arg-pos.push: maybe-unmarshal($arg, $param.type);
                            ++$i;
                        }

                        if $i < +@arg-list {
                            @arg-pos.append: @arg-list[$i..*];
                        }
                    }
                }
                else {
                    for $raw-args.kv -> $name, $arg {
                        if %sig-named{$name}:exists {
                            %arg-named{$name} = maybe-unmarshal($arg, %sig-named{$name}.type);
                        }
                        else {
                            %arg-named{$name} = $arg;
                        }
                    }
                }
                # === End of signature binding ===

                do {
                    # Handle exceptions from user code here to make the error reporting more explicit.
                    CATCH {
                        when X::Multi::NoMatch {
                            $req.respond:
                                exception => X::Cro::RPC::JSON::MethodNotFound.new(
                                    msg => "There is no matching variant for multi method '{ $req.method }' on { $obj.WHO }",
                                    data => %( method => $req.method)
                                    )
                        }
                        when X::Cro::RPC::JSON {
                            $req.respond: exception => $_;
                        }
                        default {
                            $req.respond:
                                exception => X::Cro::RPC::JSON::InternalError.new(
                                    msg => ~$_,
                                    data => %(
                                        exception => .^name,
                                        backtrace => ~.backtrace,
                                    ))
                        }
                    }

                    # Make Cro's `request` term work in actor methods
                    $req.respond: $obj.$method(|@arg-pos, |%arg-named);
                }
                LAST { call-phaser-methods 'last' }
            }
            if $websocket {
                my $*CRO-JRPC-PROTOCOL = 'WebSocket';
                my $*CRO-JRPC-ASYNC = True;

                if +(my @cmethods = json-rpc-adhoc-methods($obj, 'wsclose')) {
                    whenever $close -> $req {
                        my $*CRO-JRPC-REQUEST = $req;
                        my $close-code = ( await $req.body ).read-uint16(0);
                        for @cmethods -> &cmeth {
                            $obj.&cmeth($close-code);
                        }
                    }
                }

                for json-rpc-adhoc-methods($obj, 'async') -> &meth {
                    my @pos;
                    if &meth.signature.count > 1 && $close.defined {
                        @pos.push: $close;
                    }
                    my $asupply = $obj.&meth: |@pos;
                    whenever $asupply {
                        if $_ ~~ Cro::RPC::JSON::Notification {
                            emit $_
                        }
                        else {
                            emit Cro::RPC::JSON::Notification.new(:json-body( $_ ));
                        }
                        QUIT {
                            default {
                                emit Cro::WebSocket::Message.new(
                                    opcode => Cro::WebSocket::Message::Close,
                                    fragmented => False,
                                    body-byte-stream => supply {
                                        emit Blob.new([243, 3]);
                                        done;
                                    });
                            }
                        }
                    }
                }
            }

            CLOSE { call-phaser-methods 'close' }
        }
    }

    json-rpc(&obj-handler, :$websocket);
}

sub term:<jrpc-request>( ) is export {
    $*CRO-JRPC-REQUEST //
    X::Cro::RPC::JSON::ServerError.new(
        :msg( "jrpc-request can't be used outside of a json-rpc context" ),
        :code( JRPCNoReqObject ),
        ).throw
}
sub term:<jrpc-response>( ) is export {
    $*CRO-JRPC-RESPONSE //
    X::Cro::RPC::JSON::ServerError.new(
        :msg( "jrpc-request can't be used outside of a json-rpc context" ),
        :code( JRPCNoReqObject ),
        ).throw
}

sub term:<jrpc-protocol>( ) is export {
    $*CRO-JRPC-PROTOCOL // Nil
}
sub term:<jrpc-async>( ) is export {
    $*CRO-JRPC-ASYNC // Nil
}

sub jrpc-notify(Any:D $event) is export {
    emit Cro::RPC::JSON::Notification.new(:json-body( $event ));
}

BEGIN {
    multi trait_mod:<is>(Method:D \meth, Bool:D :$json-rpc!) is export {
        Cro::RPC::JSON::Utils::apply-json-rpc-trait(meth, :name( meth.name ));
    }

    multi trait_mod:<is>(Method:D \meth, Str:D :$json-rpc!) is export {
        Cro::RPC::JSON::Utils::apply-json-rpc-trait(meth, :name( $json-rpc ));
    }

    multi trait_mod:<is>(Method:D \meth, :$json-rpc! ( Str:D $name, *%params )) is export {
        Cro::RPC::JSON::Utils::apply-json-rpc-trait(meth, %params, :$name);
    }

    multi trait_mod:<is>(Method:D \meth, Hash:D( List:D( Pair:D ) ) :$json-rpc!) is export {
        Cro::RPC::JSON::Utils::apply-json-rpc-trait(meth, $json-rpc<>);
    }

    multi trait_mod:<is>(Mu:U \typeobj, Hash:D( List:D( Pair:D ) ) :$json-rpc-actor!) is export {
        Cro::RPC::JSON::Utils::apply-actor-trait(typeobj, $json-rpc-actor<>);
    }

    multi trait_mod:<is>(Mu:U \typeobj, Bool:D :$json-rpc-actor!) is export {
        Cro::RPC::JSON::Utils::apply-actor-trait(typeobj) if $json-rpc-actor;
    }
}

our sub META6 {
    $?DISTRIBUTION.meta
}

=begin pod

=head1 SEE ALSO

L<C<Cro>|https://cro.services>,
L<C<Cro::RPC::JSON::Message>|JSON/Message.md>,
L<C<Cro::RPC::JSON::Request>|JSON/Request.md>,
L<C<Cro::RPC::JSON::MethodResponse>|JSON/MethodResponse.md>,
L<C<Cro::RPC::JSON::Notification>|JSON/Notification.md>

=head1 AUTHOR

Vadim Belman <vrurg@cpan.org>

=head1 LICENSE

Artistic License 2.0

See the LICENSE file in this distribution.

=end pod

# Copyright (c) 2018-2021, Vadim Belman <vrurg@cpan.org>


