### ----------------------------------------------------
### -- IO::Socket::Async::SSL
### -- Licenses: Artistic-2.0
### -- Authors: Jonathan Worthington
### -- File: lib/IO/Socket/Async/SSL.rakumod
### ----------------------------------------------------
### -- Chunk 2 of 2
(@$alpn);
                    SSL_CTX_set_alpn_protos($ctx, $buf, $buf.elems);
                }
                my $ssl = OpenSSL::SSL::SSL_new($ctx);
                my $read-bio = BIO_new(BIO_s_mem());
                my $write-bio = BIO_new(BIO_s_mem());
                check($ssl, OpenSSL::SSL::SSL_set_bio($ssl, $read-bio, $write-bio));
                with $host {
                    OpenSSL::SSL::SSL_ctrl($ssl, SSL_CTRL_SET_TLSEXT_HOSTNAME, 0, $host);
                }
                OpenSSL::SSL::SSL_set_connect_state($ssl);
                check($ssl, SSL_do_handshake($ssl));
                CATCH {
                    OpenSSL::SSL::SSL_free($ssl) if $ssl;
                    OpenSSL::Ctx::SSL_CTX_free($ctx) if $ctx;
                }
                self.bless(
                    :$sock, :$enc, :$ctx, :$ssl, :$read-bio, :$write-bio,
                    :$connected-promise, :$host, :$insecure, :$alpn
                )
            }
            await $connected-promise;
        }
    }

    method !build-client-ctx($version) {
        my $method = do given $version {
            when 2 { OpenSSL::Method::SSLv2_client_method() }
            when 3 { OpenSSL::Method::SSLv3_client_method() }
            when 1 { OpenSSL::Method::TLSv1_client_method() }
            when 1.1 { OpenSSL::Method::TLSv1_1_client_method() }
            when 1.2 { OpenSSL::Method::TLSv1_2_client_method() }
            default {
                try { OpenSSL::Method::TLSv1_2_client_method() } ||
                    try { OpenSSL::Method::TLSv1_client_method() }
            }
        }
        OpenSSL::Ctx::SSL_CTX_new($method)
    }

    #| Open a socket on the specified host and port, and start listening
    #| for incoming TLS connections. Returns a Supply, upon which
    #| successfully established incoming TLS connections will be
    #| emitted.
    method listen(IO::Socket::Async::SSL:U: Str() $host, Int() $port,
                  Int() $backlog = 128,
                  :$enc = 'utf8', :$scheduler = $*SCHEDULER,
                  OpenSSL::ProtocolVersion :$version = -1,
                  :$certificate-file, :$private-key-file, :$alpn,
                  Str :$ciphers, :$prefer-server-ciphers, :$no-compression,
                  :$no-session-resumption-on-renegotiation --> Supply) {
        self!server-setup:
            IO::Socket::Async.listen($host, $port, $backlog, :$scheduler),
            :$enc, :$version, :$certificate-file, :$private-key-file,
            :$alpn, :$ciphers, :$prefer-server-ciphers, :$no-compression,
            :$no-session-resumption-on-renegotiation;
    }

    #| Upgrade an existing server socket to TLS. This is useful when
    #| implementing StartTLS. It is important that the plaintext tap
    #| of the asynchronous socket's Supply is closed, so that it can
    #| be re-tapped by this module. Returns a Supply that will emit
    #| IO::Socket::Async::SSL instance provided the upgrade succeeds,
    #| or quit if it fails.
    method upgrade-server(IO::Socket::Async::SSL:U: IO::Socket::Async:D $socket,
                  :$enc = 'utf8', OpenSSL::ProtocolVersion :$version = -1,
                  :$certificate-file, :$private-key-file, :$alpn,
                  Str :$ciphers, :$prefer-server-ciphers, :$no-compression,
                  :$no-session-resumption-on-renegotiation --> Supply) {
        # Get the setup work onto another thread.
        supply whenever Promise.kept() {
            my $setup-supply = self!server-setup:
                $socket,
                :$enc, :$version, :$certificate-file, :$private-key-file,
                :$alpn, :$ciphers, :$prefer-server-ciphers, :$no-compression,
                :$no-session-resumption-on-renegotiation;
            whenever $setup-supply {
                .emit;
            }
        }
    }

    method !server-setup($connection-source,
                  :$enc, OpenSSL::ProtocolVersion :$version,
                  :$certificate-file, :$private-key-file, :$alpn,
                  Str :$ciphers, :$prefer-server-ciphers, :$no-compression,
                  :$no-session-resumption-on-renegotiation) {
        sub alpn-selector($ssl, $out, $outlen, $in, $inlen, $arg) {
            my $buf = Buf.new;
            for (0...$inlen-1) {
                $buf.push: $in[$_];
            }
            my $protos = parse-protocol-list($buf, $inlen);
            my $result;

            if $alpn ~~ Callable {
                $result = $alpn($protos);
            } else {
                return SSL_TLSEXT_ERR_NOACK if $alpn.elems == 0;
                for @$protos -> $p {
                    $alpn.map({ if ($_ eq $p) { $result = $p; } });
                    last if $result;
                }
            }

            return SSL_TLSEXT_ERR_ALERT_FATAL unless $result;
            $out[0] = CArray[uint8].new($result.encode('ascii').list);
            $outlen[0] = $result.chars;
            SSL_TLSEXT_ERR_OK;
        }

        supply {
            # Build context, which we'll share between connections.
            my $ctx;
            $lib-lock.protect: {
                $ctx = self!build-server-ctx($version);
                my ($have-cert, $have-pkey);
                with $certificate-file {

                    die X::IO::Socket::Async::SSL.new(
                            message => "can not read certificate-file: $certificate-file"
                        ) unless $certificate-file.IO.r;

                    if 1 == OpenSSL::Ctx::SSL_CTX_use_certificate_chain_file($ctx,
                        $certificate-file.Str)
                    {
                        $have-cert = 'PEM';
                    } elsif 1 == OpenSSL::Ctx::SSL_CTX_use_certificate_file($ctx,
                            $certificate-file.Str, 2)
                    {
                        $have-cert = 'DER';
                    } else {
                        # Failed to import either PEM chain or ASN1 certificate file
                        # Proceeding with PKCS12
                        my $p12buf = slurp $certificate-file, :bin;
                        my Pointer $pkcs12 = d2i_PKCS12(Pointer,
                            CArray[CArray[uint8]].new([CArray[uint8].new($p12buf)]),
                            $p12buf.elems);
                        die "Failed to import $certificate-file as PEM/ASN1/PKCS12"
                            unless so $pkcs12;
                        my $pkey = CArray[Pointer].new([Pointer.new]);
                        my $cert = CArray[Pointer].new([Pointer.new]);
                        my $chain = CArray[Pointer].new([Pointer.new]);
                        # TODO: Passphrase handling
                        die "Failed to parse $certificate-file as PKCS12"
                            unless 1 == PKCS12_parse($pkcs12, '', $pkey, $cert, $chain);
                        if so $pkey[0] {
                            $have-pkey = 'PKCS12';
                            OpenSSL::Ctx::SSL_CTX_use_PrivateKey($ctx, $pkey[0]);
                            OpenSSL::EVP::EVP_PKEY_free($pkey[0]);
                        }
                        if so $cert[0] {
                            $have-cert = 'PKCS12';
                            OpenSSL::Ctx::SSL_CTX_use_certificate($ctx, $cert[0]);
                            OpenSSL::X509::X509_free($cert[0]);
                        }
                        if so $chain[0] {
                            for (0..OpenSSL::Stack::sk_num(nativecast(OpenSSL::Stack, $chain[0]))) {
                                my $x509 = OpenSSL::Stack::sk_value(nativecast(OpenSSL::Stack, $chain[0]), $_);
                                # #define SSL_CTX_add_extra_chain_cert(ctx,x509) \
                                #       SSL_CTX_ctrl(ctx,SSL_CTRL_EXTRA_CHAIN_CERT,0,(char *)x509)
                                if so $x509 {
                                    OpenSSL::Ctx::SSL_CTX_ctrl($ctx, 14, 0, $x509);
                                }
                            }
                            OpenSSL::Stack::sk_free(nativecast(OpenSSL::Stack, $chain[0]));
                        }
                    }
                    die "No server certificate in $certificate-file" without $have-cert;
                }
                with $private-key-file {
                    die "Private key already added as $have-pkey" with $have-pkey;
                    OpenSSL::Ctx::SSL_CTX_use_PrivateKey_file($ctx,
                        $private-key-file.Str, 1);
                }
                with get_dh2048() {
                    if SSL_CTX_ctrl_DH($ctx, SSL_CTRL_SET_TMP_DH, 0, $_) == 0 {
                        warn "IO::Socket::Async::SSL: Failed to set temporary DH";
                    }
                }
                else {
                    warn "IO::Socket::Async::SSL: Failed to create DH";
                }
                with get_ecdh() {
                    if SSL_CTX_ctrl_ECDH($ctx, SSL_CTRL_SET_TMP_ECDH, 0, $_) == 0 {
                        warn "IO::Socket::Async::SSL: Failed to set temporary ECDH";
                    }
                }
                else {
                    warn "IO::Socket::Async::SSL: Failed to create ECDH";
                }
                with $ciphers {
                    if SSL_CTX_set_cipher_list($ctx, $ciphers) == 0 {
                        die "No ciphers from the provided list were selected";
                    }
                }
                if $prefer-server-ciphers {
                    OpenSSL::Ctx::SSL_CTX_ctrl($ctx, SSL_CTRL_OPTIONS,
                        SSL_OP_CIPHER_SERVER_PREFERENCE, Str);
                }
                if $no-compression {
                    OpenSSL::Ctx::SSL_CTX_ctrl($ctx, SSL_CTRL_OPTIONS,
                        SSL_OP_NO_COMPRESSION, Str);
                }
                if $no-session-resumption-on-renegotiation {
                    OpenSSL::Ctx::SSL_CTX_ctrl($ctx, SSL_CTRL_OPTIONS,
                        SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION, Str);
                }

                if $alpn.defined {
                    SSL_CTX_set_alpn_select_cb(
                        $ctx,
                        &alpn-selector,
                        Pointer);
                }
            }

            CLOSE {
                $lib-lock.protect: {
                    if $ctx {
                        OpenSSL::Ctx::SSL_CTX_free($ctx);
                        $ctx = Nil;
                    }
                }
            }

            if $connection-source ~~ Supply {
                whenever $connection-source -> $sock {
                    handle-connection($sock);
                }
            }
            else {
                handle-connection($connection-source);
            }

            sub handle-connection($sock) {
                my $accepted-promise = Promise.new;
                $lib-lock.protect: {
                    with $ctx {
                        my $ssl = OpenSSL::SSL::SSL_new($ctx);
                        my $read-bio = BIO_new(BIO_s_mem());
                        my $write-bio = BIO_new(BIO_s_mem());
                        check($ssl, OpenSSL::SSL::SSL_set_bio($ssl, $read-bio, $write-bio));
                        OpenSSL::SSL::SSL_set_accept_state($ssl);
                        CATCH {
                            .note;
                            OpenSSL::SSL::SSL_free($ssl) if $ssl;
                            OpenSSL::Ctx::SSL_CTX_free($ctx) if $ctx;
                        }
                        self.bless(
                            :$sock, :$enc, :$ssl, :$read-bio, :$write-bio,
                            :$accepted-promise, :$alpn
                        )
                    } else {
                        $accepted-promise.break;
                    }
                }
                whenever $accepted-promise -> $ssl-socket {
                    emit $ssl-socket;
                    QUIT {
                        default {
                            # If the handshake failed, drop the connection.
                            $sock.close;
                        }
                    }
                }
            }
        }
    }

    method !build-server-ctx($version) {
        my $method = do given $version {
            when 2 { OpenSSL::Method::SSLv2_server_method() }
            when 3 { OpenSSL::Method::SSLv3_server_method() }
            when 1 { OpenSSL::Method::TLSv1_server_method() }
            when 1.1 { OpenSSL::Method::TLSv1_1_server_method() }
            when 1.2 { OpenSSL::Method::TLSv1_2_server_method() }
            default {
                try { OpenSSL::Method::TLSv1_2_server_method() } ||
                    try { OpenSSL::Method::TLSv1_server_method() }
            }
        }
        OpenSSL::Ctx::SSL_CTX_new($method)
    }

    method !handle-buffers() {
        if !$!ssl {
            # Connection no longer active; don't do anything.
        }
        elsif $!connected-promise || $!accepted-promise {
            loop {
                my $buf = buf8.allocate(32768);
                my $bytes-read = OpenSSL::SSL::SSL_read($!ssl, $buf, 32768);
                if $bytes-read > 0 {
                    $!bytes-received.emit($buf.subbuf(0, $bytes-read));
                }
                elsif $bytes-read == 0 {
                    last;
                }
                else {
                    check($!ssl, $bytes-read);
                    last;
                }
            }
            with $!shutdown-promise {
                if check($!ssl, OpenSSL::SSL::SSL_shutdown($!ssl)) >= 0 {
                    $!shutdown-promise.keep(True) unless $!shutdown-promise;
                }
                self!flush-read-bio();
            }
            CATCH {
                default {
                    $!bytes-received.quit($_);
                }
            }
        }
        orwith $!connected-promise {
            if check($!ssl, OpenSSL::SSL::SSL_connect($!ssl), 1) > 0 {
                # ALPN check
                if $!alpn.defined && $!alpn-result !~~ Nil|Buf {
                    self!check-alpn;
                } else {
                    $!alpn-result := Nil;
                }
                if $!insecure {
                    $!connected-promise.keep(self) if $!connected-promise.status ~~ Planned;
                }
                else {
                    my $cert = SSL_get_peer_certificate($!ssl);
                    if $cert {
                        if self!hostname-mismatch($cert) -> $message {
                            $!connected-promise.break(X::IO::Socket::Async::SSL::Verification.new(
                                :$message
                            ));
                        }
                        elsif (my $verify = SSL_get_verify_result($!ssl)) == 0 {
                            $!connected-promise.keep(self);
                        }
                        else {
                            my $reason = %VERIFY_FAILURE_REASONS{$verify} // 'unknown failure';
                            $!connected-promise.break(X::IO::Socket::Async::SSL::Verification.new(
                                message => "Server certificate verification failed: $reason"
                            ));
                        }
                    }
                    else {
                        $!connected-promise.break(X::IO::Socket::Async::SSL::Verification.new(
                            message => 'Server did not provide a certificate to verify'
                        ));
                    }
                }
            }
            self!flush-read-bio();
            CATCH {
                default {
                    if $!connected-promise {
                        $!bytes-received.quit($_);
                    }
                    else {
                        $!connected-promise.break($_);
                    }
                }
            }
        }
        orwith $!accepted-promise {
            if check($!ssl, OpenSSL::SSL::SSL_accept($!ssl)) >= 0 {
                # ALPN
                if $!alpn.defined && $!alpn-result !~~ Nil|Buf {
                    self!check-alpn;
                } else {
                    $!alpn-result := Nil;
                }
                $!accepted-promise.keep(self) if $!accepted-promise.status ~~ Planned;
            }
            self!flush-read-bio();
            CATCH {
                default {
                    if $!accepted-promise {
                        $!bytes-received.quit($_);
                    }
                    else {
                        $!accepted-promise.break($_) if $!accepted-promise.status ~~ Planned;
                    }
                }
            }
        }
    }

    method !check-alpn() {
        my $protocol = CArray[CArray[uint8]].new;
        $protocol[0] = CArray[uint8].new;
        my uint32 $len;
        SSL_get0_alpn_selected($!ssl, $protocol, $len);
        if $len == 0 {
            $!alpn-result = Nil;
        } else {
            for (0...$len-1) {
                $!alpn-result ~= chr($protocol[0][$_]);
            }
        }
    }

    method !flush-read-bio(--> Nil) {
        my $buf = Buf.allocate(32768);
        while OpenSSL::Bio::BIO_read($!write-bio, $buf, 32768) -> $bytes-read {
            last if $bytes-read < 0;
            my $p = $!sock.write($buf.subbuf(0, $bytes-read));
            @!outstanding-writes.push($p);
            $p.then: {
                $lib-lock.protect: {
                    @!outstanding-writes .= grep({ $_ !=== $p });
                }
            }
        }
    }

    method !hostname-mismatch($cert) {
        my $altnames = X509_get_ext_d2i($cert, NID_subject_alt_name, CArray[int32], CArray[int32]);
        my $fold-host = $!host.fc;
        if ($altnames) {
            my @no-match;
            loop (my int $i = 0; $i < $altnames.num; $i++) {
                my $gd = nativecast(GENERAL_NAME, $altnames.data[$i]);
                my $out = CArray[CArray[uint8]].new;
                $out[0] = CArray[uint8];
                my $name-bytes = ASN1_STRING_to_UTF8($out, $gd.data);
                my $name = Buf.new($out[0][^$name-bytes]).decode('utf-8');
                given $gd.type {
                    when GEN_DNS {
                        my $fold-name = $name.fc;
                        return if $fold-name eq $fold-host ||
                                  wildcard-match($fold-name, $fold-host);
                        push @no-match, $name;
                    }
                    # TODO IP address case
                }
            }
            if @no-match {
                return "Host $!host does not match any subject alt name on the " ~
                    "certificate (@no-match.join(', '))";
            }
        }
        else {
            # TODO Common names fallback
            return "Certificate contains no altnames to check host against";
        }
        Nil
    }

    # Implements the rules from RFC 6125 section 6.4.3.
    sub wildcard-match($name, $host) {
        return False without $name.index('*');
        my ($name-wild, $rest-name) = $name.split('.', 2);
        my ($host-wild, $rest-host) = $host.split('.', 2);
        return False unless $rest-name eq $rest-host;
        if $name-wild eq '*' {
            return True;
        }
        elsif $host-wild.chars < $name-wild.chars - 1 {
            # fo*od can match foxod or food but never fod.
            return False;
        }
        elsif $name-wild ~~ /^ (<-[*]>*) '*' (<-[*]>*) $/ {
            return $host-wild.starts-with(~$0) &&
                   $host-wild.ends-with(~$1);
        }
        return False;
    }

    sub parse-protocol-list($array, $len --> List) {
        my @result;
        my $names = $array;
        my $rest = $len;
        while $rest {
            my $size = $names[0];
            @result.push: $names.subbuf(1, $size).decode;
            $names .= subbuf($size+1);
            $rest -= $size + 1;
        }
        @result;
    }

    sub build-protocol-list(@protocols --> Buf) {
        my $list = Buf.new;
        for @protocols -> $p {
            $list.push: $p.chars;
            $list.push: $p.encode('ascii')
        }
        $list;
    }

    my constant SSL_ERROR_WANT_READ = 2;
    my constant SSL_ERROR_WANT_WRITE = 3;
    sub check($ssl, $rc, $expected = 0) {
        if $rc < $expected {
            my $error = OpenSSL::Err::ERR_get_error();
            my @log;
            while ($error != 0|SSL_ERROR_WANT_READ|SSL_ERROR_WANT_WRITE) {
                @log.push(OpenSSL::Err::ERR_error_string($error, Nil));
                $error = OpenSSL::Err::ERR_get_error();
            }
            if @log.elems != 0 {
                die X::IO::Socket::Async::SSL.new(
                    message => @log.join("\n")
                )
            }
        }
        $rc
    }

    #| Get a Supply of incoming data, either as a byte buffer if the :bin
    #| option is passed, or as strings otherwise. Note that strings will,
    #| in applicable encodings, be produced in NFG.
    method Supply(:$bin, :$enc = $!enc, :$scheduler = $*SCHEDULER --> Supply) {
        if $bin {
            $!bytes-received.Supply.Channel.Supply
        }
        else {
            supply {
                my $norm-enc = Rakudo::Internals.NORMALIZE_ENCODING($enc // 'utf-8');
                my $dec = Encoding::Registry.find($norm-enc).decoder();
                whenever $!bytes-received.Supply.Channel.Supply {
                    $dec.add-bytes($_);
                    emit $dec.consume-available-chars();
                    LAST if $dec.consume-all-chars() -> $final-chars {
                        emit $final-chars;
                    }
                }
            }
        }
    }

    #| Encode a string and send its bytes over the TLS connection. Returns
    #| a Promise that will be kept if the data is sent, and broken in the
    #| case of an error.
    method print(IO::Socket::Async::SSL:D: Str() $str, :$scheduler = $*SCHEDULER --> Promise) {
        self.write($str.encode($!enc // 'utf-8'), :$scheduler)
    }

    #| Send the bytes in the passed blob over the TLS connection. Returns
    #| a Promise that will be kept if the data is sent, and broken in the
    #| case of an error.
    method write(IO::Socket::Async::SSL:D: Blob $b, :$scheduler = $*SCHEDULER) {
        $lib-lock.protect: {
            if $!closed {
                my $p = Promise.new;
                $p.break(X::IO::Socket::Async::SSL.new(
                    message => 'Cannot write to closed socket'
                ));
                return $p;
            }
            my $ret = OpenSSL::SSL::SSL_write($!ssl, $b, $b.bytes);
            my $p = start {
                $lib-lock.protect: {
                    self!flush-read-bio();
                    # The following doesn't race on $p assignment due to the
                    # holding of $lib-lock in the code with the assignment.
                    @!outstanding-writes .= grep({ $_ !=== $p });
                }
                $ret
            }
            @!outstanding-writes.push($p);
            $p
        }
    }

    #| Get the peer (remote) host
    method peer-host() {
        $!sock.peer-host;
    }

    #| Get the peer (remote) port
    method peer-port() {
        $!sock.peer-port;
    }

    #| Get the socket (local) host
    method socket-host() {
        $!sock.socket-host;
    }

    #| Get the socket (local) port
    method socket-port() {
        $!sock.socket-port;
    }

    #| Get the socket native descriptor
    method native-descriptor() {
        $!sock.native-descriptor;
    }

    #| Closes the connection. This will await the completion of any
    #| outstanding writes before closing.
    method close(IO::Socket::Async::SSL:D: --> Nil) {
        my @wait-writes;
        $lib-lock.protect: {
            $!closed = True;
            if @!outstanding-writes {
                @wait-writes = @!outstanding-writes;
            }
            else {
                return if $!shutdown-promise;
                without $!shutdown-promise {
                    $!shutdown-promise = Promise.new;
                    $!shutdown-promise.then: {
                        $!sock.close;
                        self!cleanup();
                    }
                    self!handle-buffers();
                }
            }
        }
        if @wait-writes {
            Promise.allof(@wait-writes).then({ self.close });
        }
        else {
            await $!shutdown-promise;
        }
    }

    my $alpn;

    #| Check if ALPN support is available
    method supports-alpn(--> Bool) {
        $alpn //= so try {
            my $ctx = self!build-client-ctx(-1);
            my $buf = build-protocol-list(['h2']);
            SSL_CTX_set_alpn_protos($ctx, $buf, $buf.elems);
            LEAVE OpenSSL::Ctx::SSL_CTX_free($ctx) if $ctx;
            True
        }
    }

    method DESTROY() {
        self!cleanup();
    }

    method !cleanup() {
        if $!ssl || $!ctx {
            start $lib-lock.protect: {
                if $!ssl {
                    OpenSSL::SSL::SSL_free($!ssl);
                    $!ssl = Nil;
                }
                if $!ctx {
                    OpenSSL::Ctx::SSL_CTX_free($!ctx);
                    $!ctx = Nil;
                }
                $!read-bio = Nil;
                $!write-bio = Nil;
            }
        }
    }
}

=begin pod

=head2 Bugs, feature requests, and contributions

Please use GitHub Issues to file bug reports and feature requests.
If you wish to contribute to this module, please open a GitHub Pull
Request.

Please send an email to the Raku Security Team (security@raku.org)
to report security vulnerabilities.

=head1 AUTHOR

Jonathan Worthington

=head1 COPYRIGHT AND LICENSE

Copyright 2017 - 2024 Jonathan Worthington

Copyright 2024 - 2025 Raku Community

This library is free software; you can redistribute it and/or modify it under the Artistic License 2.0.

=end pod


