💾 Archived View for thrig.me › tech › ssl › pingpong.tcl captured on 2024-06-16 at 13:40:15.

View Raw

More Information

⬅️ Previous capture (2023-04-19)

-=-=-=-=-=-=-

#!/usr/bin/env tclsh8.6
#
# pingpong - send a ping, get a pong. this code contains both the client
# and the server, both of which require the CA certificate for
# verification. The CA certificate could be a self-signed certificate
#
#   ./pingpong.tcl host.cert host.cert host.key
#
# in which case only the certificate will be verified against itself.
# More typical is for a distinct root certificate to have signed some
# certificate, so any certificate signed by said root should work
#
#   ./pingpong.tcl minca.cert minca-test.cert minca-test.key

# on OpenBSD:
#   doas pkg_add tcl tcltls
package require Tcl 8.6
package require tls

if {[llength $argv] == 3} {
    set ca_cert_file [lindex $argv 0]
    set cert_file [lindex $argv 1]
    set key_file [lindex $argv 2]
} else {
    puts stderr "Usage: pingpong ca-cert-file cert-file key-file"
    exit 1
}

set pings 0

proc client-response {socket} {
    global done pings
    gets $socket response
    if {$response ne ""} {
        puts stderr "CLIENT server said: $response"
        close $socket
        incr pings
        # TWEAK increase or remove so the server runs longer and can be
        # tested with other implementations, e.g. nc(1)
        if {$pings >= 3} {set done 1}
    }
}

proc client-request {host port} {
    global ca_cert_file cert_file key_file
    set socket [tls::socket -tls1 true -ssl2 false -ssl3 false -require 1 \
     -cafile $ca_cert_file -certfile $cert_file -keyfile $key_file $host $port]
    socket-config $socket
    puts stderr "CLIENT $host $port pinging"
    puts $socket PING
    fileevent $socket readable [list client-response $socket]
    client-spawn-after 500 $host $port
}

proc client-spawn-after {delay host port} {
    after $delay client-request localhost $port
}

proc server-response {socket} {
    gets $socket request
    if {$request eq "PING"} {
        puts stderr "SERVER ponging"
        puts $socket "PONG [clock milliseconds]"
        close $socket
    }
}

proc server-spawn {socket addr port} {
    puts stderr "SERVER client $addr $port"
    socket-config $socket
    fileevent $socket readable [list server-response $socket]
}

proc socket-config {socket} {
    fconfigure $socket -blocking 0 -buffering none -translation crlf \
     -encoding utf-8
}

set sock [tls::socket -server server-spawn \
 -tls1 true -ssl2 false -ssl3 false -require 1 \
 -cafile $ca_cert_file \
 -certfile $cert_file -keyfile $key_file 0]
set port [lindex [chan configure $sock -sockname] end]
puts stderr "SERVER listen $port"

client-spawn-after 500 localhost $port

vwait done