Artifact 81a3a7f4389bbd9c87baea0e4bf979b1e702587a:

• File packages/keep/bin/serve — part of check-in [eeb68f6b7c] at 2020-05-24 20:35:08 on branch trunk — gryp

  further work on encryption routines

  keep

  rework [setbatch]

  list new routine

  struncate

  (user: pooryorick size: 5756)

#! /usr/bin/env tclsh

apply [list {} {
	while 1 {
		set ns [info cmdcount]
		if {![namespace exists $ns]} break
	}
	namespace eval $ns {
		variable magic lGrLMS60bip3LjM8MIrkFuV#0uR4sikAcVh@W#V#

		package require {ycl proc}
		[yclprefix] proc alias alias [yclprefix] proc alias
		alias aliases [yclprefix] proc aliases

		aliases {
			{ycl chan chan} {
				command
			}
			{ycl dict deep}
			{ycl dict} {
				ddict deep
			}
			{ycl keep keep}
			{ycl list} {
				take
			}
			{ycl proc} {
				optswitch
			}
			{ycl string printable}
		}

		package require pki


		proc accept {} {
			variable responders {}
			variable requests
			while 1 {
				if {[llength $requests]} {
					take requests request
					take request chan host port
				} else {
					lappend responders [info coroutine]
					yield
					continue
				}
				chan configure $chan -encoding utf-8 -eofchar {} -translation lf
				repl $host $port $chan
			}
		}


		proc enqueue args  {
			variable maxrequests
			variable responders
			variable requests
			variable serverchan

			if {[llength $requests] > $maxrequests} {
				puts [list {too many requests}]
				take args chan host port
				catch {error {try again later}} cres copts
				respond $chan 0 $cres $copts
				close $serverchan
				after 1000 [list [namespace which mayberestart]]
			} else {
				puts [list enqueing request $args]
				lappend requests $args
				if {[llength $responders]} {
					take responders responder
					after 0 [list $responder]
				}
			}
			return
		}


		proc listen args {
			variable maxrequests
			variable serverargs
			variable serverport
			variable serverchan
			variable requests
			#package require tls
			dict size $args
			if {![info exists serverargs]} {
				set serverargs {}
			}
			if {![info exists maxrequests]} {
				set maxrequests 512
			}
			foreach {opt val} $args {
				switch $opt {
					port {
						set serverport $val
					}
					default {
						error [list {unknown option} $opt]
					}
				}
			}
			set serverchan [socket -server [list [
				namespace which enqueue]] {*}$serverargs $serverport]
			set sockets [chan configure $serverchan -sockname]
			puts [list listening sockets $sockets]
		}


		proc mayberestart args {
			variable maxrequests
			variable requests
			if {$requests < $maxrequests} {
				listen
			} else {
				after 1000 [list [namespace which mayberestart]]
			}
		}


		proc respond {chan encrypted cres copts} {
			ddict set rheader counter [keep counter]
			set response [list $rheader [list $cres[set cres {}] $copts[
				set copts {}]]]
			puts [list response size [
				string length $response] value [
					printable tcl 0 ascii 0 [string range $response 0 511]]]
			if {$encrypted} {
				puts [list {encrypting response}]
				ddict set rheader2 encrypted 1

				set key [keep pkikey]

				#set mypubkey [keep pubkey]
				#set encrypted [keep encrypt -binary -pad -priv -- \
				#	$response #$key]
				#set decrypted [keep decrypt -binary  -unpad -pub -- \
				#	$encrypted $mypubkey]
				#if {$decrypted eq $response} {
				#	puts [list {decryption check ok}]
				#} else {
				#	error [list {encryption check failed} {original len} [
				#		string length $response] {decrypted len} [
				#			string length $decrypted] ]
				#	]
				#	puts [list {original value}]
				#	puts [printable tcl 0 ascii 0 $response]
				#	puts [list {decrypted value}]
				#	puts [printable tcl 0 ascii 0 $decrypted]
				#	error [list {encryption failure}] 
				#}

				set response [list $rheader2 [
					keep encrypt -pad -binary -priv -- $response $key]]

			}
			puts [list responding chan $chan size [
				string length $response] value [
					printable tcl 0 ascii 0 [string range $response 0 511]]]
			puts $chan [list $response]
			flush $chan
			# for now, let the client close the channel
			# {to do} channel monitor
			#close $chan
		}


		proc main {argv0 argv} {
			variable responders {}
			variable requests {}

			set listenargs {}

			while {[llength $argv]} {
				take argv arg
				optswitch $arg {
					keep {
						take argv keep
					}
					port {
						take argv port
					}
				}
			}

			[yclprefix] keep keep .new [namespace current]::keep
			puts [list initializing keep]
			keep .init workdir $keep
			keep pkikey
			puts [list done initializing]
			if {![info exists port]} {
				set port [dict get [keep defaults] listen port]
			}
			coroutine accept[info cmdcount] accept
			lappend listenargs port $port
			listen {*}$listenargs
		}


		proc repl {host port chan} {
			while 1 {
				puts [list request from host $host port $port chan $chan]
				set count [command $chan command]
				if {$count < 0} {
					if {[eof $chan]} {
						close $chan
						break
					} else {
						continue
					}
				}
				set status [catch {
					puts [list received command [printable tcl 0 ascii 0 [
						string range $command 0 511]]]
					lassign $command[set command {}] header command
					if {[dict exists $header encrypted]} {
						set encrypted 1
						set key [keep pkikey]
						set command [keep decrypt -binary -unpad -priv -- $command[
							set command {}] $key]
						puts [list decrypted [printable tcl 0 ascii 0 [
							string range $command 0 511]]]
						lassign $command[set command {}] header1 command
					} else {
						set encrypted 0
					}
					set command [zlib decompress $command[set command {}]]
					keep dispatch {*}$command
				} cres copts]
				try {
					respond $chan $encrypted $cres $copts
				} on error {cres copts} {
					puts stderr [list {error resonding} \
						chan $chan host $host port $port]
					puts stderr [dict get $copts -errorinfo]
					break
				}
			}
		}


		after 0 [list [namespace which main] $argv0 $argv]
		vwait [namespace current]::status
		exit $status
	}
} [namespace current]]