#
# Расширение пакета test для OpenSSL
#
package require http
# Путь поиска пакета test
if {[info exists env(TOOLDIR)]} {
	lappend auto_path $env(TOOLDIR)
} {
	lappend auto_path "[file dirname [info script]]/../../maketool"
}


# outputs specified environment variables into log

proc log_vars {args} {
	foreach var $args {
		if [info exists ::env($var)] {
			log $var=$::env($var)
		} else {
			log "$var is not set"
		}	
	}
}	
# Проверка наличия необходимых переменных окружения
foreach var {OPENSSL_APP} {
if {![info exists env($var)]} {
	puts stderr "Environment variable $var not defined"
	exit 100
} else {
	set $var [file normalize $env($var)]
}
}

if {[info exists env(OPENSSL_CONF)]} {
	set OPENSSL_CONF $env(OPENSSL_CONF)
} else {
	if {[regexp {OPENSSLDIR: "([^\"]+)"} [exec $OPENSSL_APP version -d] => openssl_dir]} {
		set OPENSSL_CONF $openssl_dir/openssl.cnf
	} else {	
		puts stderr "Cannot find out default openssl config"
		exit 100
	}
}	

if {![file exists $OPENSSL_CONF]} {
	puts "Configuration file $OPENSSL_CONF doesn't exist"
	exit 100
}	

if {$::tcl_platform(platform) != "windows"} {
  proc kill {signal pid} {
  exec kill -$signal $pid
  }
} else {
  proc kill {signal pid} {
  exec taskkill /pid $pid /f
  }
}
	
package require test
set test::suffix ""
package require base64

#
# set  up test::src variable
#

if {[info exists env(TESTSRC)]} {
	set ::test::src [file normalize $env(TESTSRC)]
} else {
	set ::test::src [pwd]
}	

#
# set  up test::dir variable
#

if {[info exists env(TESTDIR)]} {
	set ::test::dir [file normalize $env(TESTDIR)]
} else {
	set ::test::dir [file join [pwd] z]
}	

#
# Фильтрует вывод полученный в виде длинной строки, разбивая на строки
# по \n. Возвращает строки, удовлетворяющие регулярному выражениу
# pattern
#

proc grep {pattern data} {
	set out ""
	foreach line [split $data "\n"] {
		if {[regexp $pattern $line]} {
			append out $line "\n"
		}
	}	
	return $out
}	
proc check_builtin_engine {} {
	global OPENSSL_APP
	set found [regexp Cryptocom [exec $OPENSSL_APP engine 2> /dev/null]]
	if {$found} {
		puts "Using statically compiled engine"
	} else {
		puts "Using dynamically loaded engine"
	}
	return $found
}	
	

# Вызывает команду openssl.
# Посылает в лог вывод на stdout и на stderr, возвращает его же.
proc openssl {cmdline} {
	global ENGINE_PATH OPENSSL_APP
	log_vars OPENSSL_CONF CRYPT_PARAMS RNG RNG_PARAMS CCENGINE_LICENSE
	if {[info exists ::test::engine]} {
		set cmdline [concat [lrange $cmdline 0 0] [list -engine $::test::engine] [lrange $cmdline 1 end]]
	}	
	log "OpenSSL cmdline: $OPENSSL_APP $cmdline"
	set f [open "|$OPENSSL_APP $cmdline" r]
	set output [read $f]
	if {[catch {close $f} msg]} {
		append output "STDERR CONTENTS:\n$msg"
		log $output
		if {[lindex $::errorCode 0]!="NONE"} {
			return -code error -errorcode $::errorCode $output
		}
	}	
	return $output
}	


proc getConfig {args} {
	global OPENSSL_CONF
	if {![info exists OPENSSL_CONF]} {
	  if {![regexp "OPENSSLDIR: \"\[^\"\]+\"" [openssl version -d] => openssl_dir]} {
	  	puts stderr "Cannot find out openssl directory"
		exit 1
	  }
	 set OPENSSL_CONF  "$openssl_dir/openssl.cnf"
	}
	set f [open $OPENSSL_CONF r]
	set out ""
	set mode copy
	while {[gets $f line]>=0} {
		if {[regexp	"\\s*\\\[\\s*(\\S+)\\s*\\\]" $line => section]} {
			if {[lsearch -exact $args $section]!=-1} {
				set mode skip
			} else {
				set mode copy
			}
		}
		if {$mode eq "copy"} {
			append out $line \n
		}	
	 }	
	 return $out
}	 
#
# Создает тестовый CA
# Допустимые параметры: 
# CAname - директория, в которой создается CA (testCA по умолчанию)
# алгоритм с параметрами в формате команды req
#

proc makeCA {{CAname {}} {algor_with_par gost2012_512:A}} {
	global OPENSSL_CONF
	if {![string length $CAname]} {
		set CAname [file rootname [file tail $::argv0]]CA-2012
	}	
	set test::ca $CAname
	file delete -force $CAname
	file mkdir $CAname
	makeFile $CAname/ca.conf "
\[ ca \]
default_ca      = CA_default            # The default ca section

\[ CA_default \]

dir            = [file join [pwd] $CAname]              # top dir
database       = \$dir/index.txt        # index file.
new_certs_dir  = \$dir/newcerts         # new certs dir

certificate    = \$dir/cacert.pem       # The CA cert
serial         = \$dir/serial           # serial no file
private_key    = \$dir/private/cakey.pem# CA private key
RANDFILE       = \$dir/private/.rand    # random number file

default_days   = 3650                  # how long to certify for
default_crl_days= 30                   # how long before next CRL
default_md     = default               # use digest corresponding the algorithm
default_startdate = 060101000000Z

policy         = policy_any            # default policy
email_in_dn    = yes                   #  add the email into cert D


nameopt        = ca_default            # Subject name display option
certopt        = ca_default            # Certificate display option
copy_extensions = copy                 # Copy extensions from requ


\[ policy_any \]
countryName            = supplied
stateOrProvinceName    = optional
organizationName       = optional
organizationalUnitName = optional
commonName             = supplied
emailAddress           = supplied

"	
	makeFile $CAname/req.conf "
\[req\]
prompt=no
distinguished_name = req_dn
\[ req_dn \]
C = RU
L = Moscow
CN=Test CA $algor_with_par
O=Cryptocom
OU=OpenSSL CA
emailAddress = openssl@cryptocom.ru
\[ v3_ca \]
# Extensions for a typical CA
# PKIX recommendation.
subjectKeyIdentifier=hash
authorityKeyIdentifier=keyid:always,issuer
basicConstraints = critical,CA:true

# Key usage: this is typical for a CA certificate. However since it will
# prevent it being used as an test self-signed certificate it is best
# left out by default.
# keyUsage = cRLSign, keyCertSign

# Include email address in subject alt name: another PKIX recommendation
# subjectAltName=email:copy
# Copy issuer details
# issuerAltName=issuer:copy

# DER hex encoding of an extension: beware experts only!
# obj=DER:02:03
# Where 'obj' is a standard or added object
# You can even override a supported extension:
# basicConstraints= critical, DER:30:03:01:01:FF
"
	file mkdir $CAname/private
	file mkdir $CAname/newcerts
	generate_key [keygen_params $algor_with_par] $CAname/private/cakey.pem
	openssl "req -new  -x509 -key $CAname/private/cakey.pem -nodes -out $CAname/cacert.pem -config $CAname/req.conf -reqexts v3_ca -set_serial 0x11E"
	makeFile ./$CAname/.rand 1234567890
	makeFile ./$CAname/serial 011E
	makeFile ./$CAname/index.txt ""
	return [file isfile $CAname/cacert.pem]
}

proc extract_oids {filename {format PEM} {offset 0}} {
	set out ""
	if {$offset} {
		set miscargs "-offset $offset "
	} else {
		set miscargs ""
	}	
	foreach line [split [openssl "asn1parse $miscargs-in $filename -inform $format -oid oidfile"] "\n"] {
		if {([regexp {Gost\d+} $line]||[regexp "GostR" $line]||[regexp "GOST" $line]||[regexp "sha1" $line]) && ![regexp ^Loaded: $line]} {
			regsub {[^:]+:[^:]+:} $line "" line
			append out $line "\n"
		}
	}
	return $out
}
# 
# Формирует список параметров для openssl req необходимый для формирования 
# ключа c указанным алгоритмом и параметрами
#  
proc keygen_params {alg} {	
	return [split $alg :] 
}	

proc generate_key {params filename} {
	set alg [lindex $params 0]
	set param [lindex $params 1]
	set keyname $alg
	set keyname [append keyname _ $param .pem] 
	switch -glob $alg {
	rsa { 
		if {![string length $param]} {
			set param 1024
			set keyname "rsa_1024.pem"
		}
		set optname "-algorithm rsa -pkeyopt rsa_keygen_bits:$param"
		}
	ec {set optname "-paramfile $param"}
	dsa {set optname "-paramfile $param" }
	gost* { set optname "-algorithm $alg -pkeyopt paramset:$param" }
	}	
	if {$::tcl_platform(platform) eq "windows"} {
		set exesuffix ".exe"
	} else {
		set exesuffix ""
	}
	log "Keyname is $keyname"
#	if {[engine_name] eq "open"} {
		log "Calling openssl cmd to create private key"
		openssl "genpkey  $optname -out $filename"
#	} elseif {[info exists ::env(OBJ)] && [file executable ../$::env(OBJ)/keytest$exesuffix]&& $alg eq "gost2001"} {
#		log "keytest$exesuffix $alg $param $filename"
#		exec ../$::env(OBJ)/keytest$exesuffix $alg $param $filename >&@ stdout
#	} elseif {[info exists ::env(OBJ)] && [file executable ../$::env(OBJ)/keytest$exesuffix]&& $alg eq "gost2012_256"} {
#		log "keytest$exesuffix $alg $param $filename"
#		exec ../$::env(OBJ)/keytest$exesuffix $alg $param $filename >&@ stdout
#	} elseif {[info exists ::env(OBJ)] && [file executable ../$::env(OBJ)/keytest$exesuffix]&& $alg eq "gost2012_512"} {
#		log "keytest$exesuffix $alg $param $filename"
#		exec ../$::env(OBJ)/keytest$exesuffix $alg $param $filename >&@ stdout
#	} elseif {[info exists ::env(PRIVATEKEYSDIR)] && [file exists $::env(PRIVATEKEYSDIR)/$keyname]} {
#		log "Copying file $keyname"
#		file copy $::env(PRIVATEKEYSDIR)/$keyname $filename
#	} else {
#		log "Calling openssl cmd to create private key"
#		openssl "genpkey  $optname -out $filename"
#	}
}

#
# Создает тестового пользователя с одним ключом подписи и одной заявкой
# на сертификат. 
# Параметры 
# username Имя директории, куда складывать файлы этого пользователя
# alg Параметр для опции -newkey команды openssl req, задающий алгоритм
#  ключа и параметры этого алгоритма
# Последующие параметры имеют вид списка ключ значение и задают поля
# Distinguished Name 
# FIXME Процедуру надо поправить, чтобы работала с новой версией openssl
proc makeUser {username alg args} {
	file delete -force $username
	file mkdir $username
	if {[lsearch $args CN]==-1} {
		lappend args CN $username
	}	
	makeFile $username/req.conf [eval makeConf $args]
	log "req.conf --------\n[getFile $username/req.conf]-------------"
	
	generate_key [keygen_params $alg] $username/seckey.pem
	openssl "req -new -key $username/seckey.pem -nodes -out $username/req.pem -config $username/req.conf"
	return [expr {[file size $username/req.pem] > 0}]
}

proc makeSecretKey {username alg} {
	file delete -force $username
	file mkdir $username
	generate_key [keygen_params $alg] $username/seckey.pem	
	return [expr {[file size $username/seckey.pem] > 0}]
}

#
# Создает пользователя с помощью makeUser и подписывает его сертификат
# ключом ранее созданного testCA. 
# Параметр CAname обрабатывается специальным образом: он не попадает в DN
#
proc makeRegisteredUser {username alg args } {
	if {![info exists params(CAname)]&&![info exists ::test::ca]} {
		return -code error "Default CA name is not known. Have you called makeCA earlier in this script?"
	}	
	set CAname $test::ca
	array set params $args
	if {[info exist params(CAname)]} {
		set CAname $params(CAname)
		unset params(CAname)
	}
	if {![file isdirectory $CAname]||![file exists $CAname/cacert.pem]} {
		return -code error "CA $CAname doesn't exists"
	}	
	eval makeUser [list $username $alg] [array get params]
	openssl "ca -config $CAname/ca.conf -in $username/req.pem -out $username/cert.pem -batch -notext" 
	return [file isfile $username/cert.pem]
}

proc makeConf {args} {
	global OPENSSL_CONF
	array set dn_attrs [list C  RU\
	L  Moscow\
	CN "Dummy user"\
	O Cryptocom\
	OU "OpenSSL Team"\
	emailAddress  "openssl@cryptocom.ru"\
	]
	array set dn_attrs $args
	if {[info exists dn_attrs(extensions)]} {
		set extensions $dn_attrs(extensions)
		unset dn_attrs(extensions)
	}	
	set out ""
	append out {[req]
prompt=no
distinguished_name = req_dn
}
if {[info exists extensions]} {
	append out "req_extensions = req_exts\n\[ req_exts \]\n" $extensions "\n"
}	
append out "\[ req_dn \]\n"
	foreach {key val} [array get dn_attrs] {
		append out "$key=$val\n"
	}
	return $out
}	
#
# Выполняет замену регулярного выражения re на строку s в указанном
# PEM-документе.
#
proc hackPem {re pem s} {
	set out ""
	foreach {whole_pem start_line coded_body end_line} [regexp -inline -all "(-----BEGIN \[^\n\]+-----\n)(.*?)(\n-----END \[^\n\]+-----\n)" $pem] {
		set der [::base64::decode $coded_body]
		set der [regsub -all $re $der $s]
		append out $start_line [::base64::encode $der] $end_line
	}
	return $out
}	

#
# Handling of OIDs
#

source [file dirname  [info script]]/name2oid.tcl
foreach {name oid} [array get name2oid] {
	set oid2name($oid) $name
}

proc long_name_by_id {id} {
	variable name2oid
	variable oid2name
	if {[regexp {^\d+(\.\d+)+$} $id]} {
	return "GOST $oid2name($id) $id"
	}
	return "GOST $id $name2oid($id)"
}

proc alg_id {alg} {
	switch -glob $alg {
		gost94cc {return pk_sign94_cc}
		gost94cc:* {return pk_sign94_cc}
		gost94:* {return pk_sign94_cp}
		gost2001cc:* {return pk_sign01_cc}
		gost2001cc {return pk_sign01_cc}
		gost2001:* {return pk_sign01_cp}
		gost2012_256:* {return pk_sign12_256}
		gost2012_512:* {return pk_sign12_512}
	}
}

proc alg_with_digest {alg} {
	variable name2oid
	switch -glob $alg {
		gost94cc {return hash_with_sign94_cc}
		gost94cc:* {return hash_with_sign94_cc}
		gost94:* {return hash_with_sign94_cp}
		gost2001cc:* {return hash_with_sign01_cc}
		gost2001cc {return hash_with_sign01_cc}
		gost2001:* {return hash_with_sign01_cp}
		gost2012_256:* {return hash_with_sign12_256}
		gost2012_512:* {return hash_with_sign12_512}
		
	}
}

proc alg_long_name {alg} {
	variable name2oid
	switch -glob $alg {
		#gost94cc {return hash_with_sign94_cc}
		#gost94cc:* {return hash_with_sign94_cc}
		#gost94:* {return hash_with_sign94_cp}
		#gost2001cc:* {return hash_with_sign01_cc}
		#gost2001cc {return hash_with_sign01_cc}
		gost2001:* {return "GOST R 34.10-2001"}
		gost2012_256:* {return "GOST R 34.10-2012 with 256 bit modulus"}
		gost2012_512:* {return "GOST R 34.10-2012 with 512 bit modulus"}
	}
}

# Returns hash algorithm corresponded to sign algorithm
proc alg_hash {alg} {
    switch -glob $alg {
        gost2012_256:* {return hash_12_256}
        gost2012_512:* {return hash_12_512}
        * {return hash_94}
   }
}

# Returns short name of hash algorithm
proc hash_short_name {hash_alg} {
    switch -glob $hash_alg {
        *hash_94 {return md_gost94}
        hash_12_256 {return md_gost12_256}
        hash_12_512 {return md_gost12_512}
        default {return $hash_alg}
    }
}

proc ts_hash_long_name {hash_alg} {
    switch -glob $hash_alg {
        *hash_94 {return md_gost94}
        hash_12_256 {return md_gost12_256}
        hash_12_512 {return md_gost12_512}
        default {return $hash_alg}
    }
}

# Returns long name of hash algorithm
proc hash_long_name {hash_alg} {
    switch -glob $hash_alg {
		*hash_94* {return "GOST R 34.11-94"}
		gost2001* {return "GOST R 34.11-94"}
        *12_256* {return "GOST R 34.11-2012 with 256 bit hash"}
        *12_512* {return "GOST R 34.11-2012 with 512 bit hash"}
        default {return $hash_alg}
    }
}

# Returns long name of hash_with_sign algorithm
proc hash_with_sign_long_name {alg} {
    switch -glob $alg {
        gost2001:* {return "GOST R 34.11-94 with GOST R 34.10-2001"}
        gost2012_256:* {return "GOST R 34.10-2012 with GOST R 34.11-2012 (256 bit)"}
        gost2012_512:* {return "GOST R 34.10-2012 with GOST R 34.11-2012 (512 bit)"}
        default {return $alg}
    }
}

proc smime_hash_with_sign_long_name {alg} {
    switch -glob $alg {
        hash_with_sign01_cp {return "GOST R 34.11-94 with GOST R 34.10-2001"}
        hash_with_sign12_256 {return "GOST R 34.10-2012 with GOST R 34.11-2012 (256 bit)"}
        hash_with_sign12_512 {return "GOST R 34.10-2012 with GOST R 34.11-2012 (512 bit)"}
        default {return $alg}
    }
}

proc micalg {hash_alg} {
    switch -exact $hash_alg {
        hash_94 {return "gostr3411-94"}
        hash_12_256 {return "gostr3411-2012-256"}
        hash_12_512 {return "gostr3411-2012-512"}
    }
}

proc param_pubkey {alg} {
	variable name2oid
	switch -exact $alg {
		gost94cc: {return param_pubkey94_cpa}
		gost94cc {return param_pubkey94_cpa}
		gost94:A {return param_pubkey94_cpa}
		gost94:B {return param_pubkey94_cpb}
		gost94:C {return param_pubkey94_cpc}
		gost94:D {return param_pubkey94_cpd}
		gost94:XA {return param_pubkey94_cpxcha}
		gost94:XB {return param_pubkey94_cpxchb}
		gost94:XC {return param_pubkey94_cpxchc}
		gost2001cc: {return param_pubkey01_cc}
		gost2001cc {return param_pubkey01_cc}
		gost2001:0 {return param_pubkey01_cptest}
		gost2001:A {return param_pubkey01_cpa}
		gost2001:B {return param_pubkey01_cpb}
		gost2001:C {return param_pubkey01_cpc}
		gost2001:XA {return param_pubkey01_cpxcha}
		gost2001:XB {return param_pubkey01_cpxchb}
		gost2012_256:0 {return param_pubkey01_cptest}
		gost2012_256:A {return param_pubkey01_cpa}
		gost2012_256:B {return param_pubkey01_cpb}
		gost2012_256:C {return param_pubkey01_cpc}
		gost2012_256:XA {return param_pubkey01_cpxcha}
		gost2012_256:XB {return param_pubkey01_cpxchb}
		gost2012_512:0 {return param_pubkey12_512_0}
		gost2012_512:A {return param_pubkey12_512_A}
		gost2012_512:B {return param_pubkey12_512_B}
	}
}


proc param_hash_long_name {hash_alg {pk_alg {}}} {
    # R 1323565.1.023-2018 (5.2.1.2) not recommends or forbids encoding
    # hash oid into TC26 (2012) parameters in AlgorithmIdentifier, so
    # this is removed.
    # Note:
    # Commit d47b346 reverts this behavior for 512-bit 0,A,B parameters
    switch -glob $pk_alg {
	gost2012_256:TC* {return}
	gost2012_512:C {return}
    }
    switch -glob $hash_alg {
        *hash_94 {return "id-GostR3411-94-CryptoProParamSet"}
        hash_12_256 {return "GOST R 34.11-2012 with 256 bit hash"}
        hash_12_512 {return "GOST R 34.11-2012 with 512 bit hash"}
    }
}

proc pubkey_long_name {alg} {
	variable name2oid
	switch -glob $alg {
		
		#gost2001cc: {return param_pubkey01_cc}
		#gost2001cc {return param_pubkey01_cc}
		#gost2001:0 {return param_pubkey01_cptest}
		gost2001:A {return "id-GostR3410-2001-CryptoPro-A-ParamSet"}
		gost2001:B {return "id-GostR3410-2001-CryptoPro-B-ParamSet"}
		gost2001:C {return "id-GostR3410-2001-CryptoPro-C-ParamSet"}
		gost2001:XA {return "id-GostR3410-2001-CryptoPro-XchA-ParamSet"}
		gost2001:XB {return "id-GostR3410-2001-CryptoPro-XchB-ParamSet"}
		gost2012_256:0 {return "id-GostR3410-2001-TestParamSet"}
		gost2012_256:A {return "id-GostR3410-2001-CryptoPro-A-ParamSet"}
		gost2012_256:B {return "id-GostR3410-2001-CryptoPro-B-ParamSet"}
		gost2012_256:C {return "id-GostR3410-2001-CryptoPro-C-ParamSet"}
		gost2012_256:XA {return "id-GostR3410-2001-CryptoPro-XchA-ParamSet"}
		gost2012_256:XB {return "id-GostR3410-2001-CryptoPro-XchB-ParamSet"}
		gost2012_256:TCA {return "GOST R 34.10-2012 (256 bit) ParamSet A"}
		gost2012_256:TCB {return "GOST R 34.10-2012 (256 bit) ParamSet B"}
		gost2012_256:TCC {return "GOST R 34.10-2012 (256 bit) ParamSet C"}
		gost2012_256:TCD {return "GOST R 34.10-2012 (256 bit) ParamSet D"}
		#gost2012_512:0 {return param_pubkey12_512_0}
		gost2012_512:A {return 	"GOST R 34.10-2012 (512 bit) ParamSet A"}
		gost2012_512:B {return 	"GOST R 34.10-2012 (512 bit) ParamSet B"}
		gost2012_512:C {return  "GOST R 34.10-2012 (512 bit) ParamSet C"}
	}
}

proc mkObjList {args} {
	set out ""
	foreach name $args {
		if {$name eq {}} continue
		append out " OBJECT            :$name\n"
	}
	return $out
}

proc structured_obj_list {args} {
	variable name2oid
	set out {}
	foreach {path name} $args {
		if {$name != {}} {set oid $name2oid($name)} {set oid {}}
		lappend out "$path=$oid"
	}
	return $out
}

proc param_hash {alg} {
    switch -glob $alg {
        gost2012_256:* {return hash_12_256}
        gost2012_512:* {return hash_12_512}
        * {return param_hash_94}
    }
}


proc param_encr {short_name} {
	variable name2oid
	if {[regexp {^\d+(\.\d+)+$} $short_name]} {
	return "$short_name"
	}
	switch -exact $short_name {
		cc_cipher_param {return param_encr_cc}
		{} {return param_encr_tc}
		cp_cipher_param_a {return param_encr_cpa}
		cp_cipher_param_b {return param_encr_cpb}
		cp_cipher_param_c {return param_encr_cpc}
		cp_cipher_param_d {return param_encr_cpd}
	}
}

proc encr_long_name {short_name} {
	variable name2oid
	switch -exact $short_name {
		"1.2.643.2.2.31.1" {return "id-Gost28147-89-CryptoPro-A-ParamSet"}
		"1.2.643.2.2.31.2" {return "id-Gost28147-89-CryptoPro-B-ParamSet"}
		"1.2.643.2.2.31.3" {return "id-Gost28147-89-CryptoPro-C-ParamSet"}
		"1.2.643.2.2.31.4" {return "id-Gost28147-89-CryptoPro-D-ParamSet"}
		"1.2.643.7.1.2.5.1.1" {return "GOST 28147-89 TC26 parameter set"}
		{} {return "GOST 28147-89 TC26 parameter set"}
	}
}



#
# Функции для управления клиентом и сервером при тестировании
# SSL-соединения
#

#  Параметры
#    Список аргументов командной строки клиента
#    список аргументов командной строки сервера
#    строка, которую надо передать на stdin клиенту
#
# Запускает openssl s_server и пытается приконнектиться к нему openssl
# s_client-ом. Возвращает список stdout  клиента, stderr клиента, кода
# завершения клиента, stdout
# сервера stderr сервера и кода завершения сервера.
# 
# Если процесс убит сигналом, возвращает в качестве кода завершения имя
# сигнала, иначе - числовое значение кода завершения ОС
# 
proc client_server {client_args server_args client_stdin} {
	log "CLIENT ARGS\n$client_args\n"
	log "SERVER ARGS\n$server_args\n"
	flush [test_log]
	set server [open_server $server_args]
	set client [open_client $client_args $client_stdin]
	log "server = $server client = $client"
	log "Both client and server started"
	flush [test_log]
	global finished
	log "Waitng for client to termintate"
	flush [test_log]
#	if {$::tcl_platform(platform) == "windows"} {
#		exec ../kbstrike [pid $client] 0x20
#	}
	vwait finished($client) 
	catch {stop_server $server}
	set list [concat [stop $client] [stop $server]]
	foreach channel {"CLIENT STDOUT" "CLIENT STDERR" "CLIENT EXIT CODE"  "SERVER STDOUT"
	"SERVER STDERR" "SERVER EXIT CODE"} data $list {
		log "$channel\n$data\n"
	}
	return $list
}
#
# Устанавливает командную строку для вызова клиента,
# в системный openssl на указанном хосте
#
proc remote_client {host} {
	if {[info hostname] == "$host"} {
		set ::test::client_unset {OPENSSL_CONF}
		set ::test::client_app "openssl s_client"
	} else {
		set ::test::client_unset {LD_LIBRARY_PATH OPENSSL_CONF}
		set ::test::client_app "ssh build@$host openssl s_client"
	}
}	
#
# Устанавливает командную строку для вызова клиента в указанную команду
# Необязательный параметр указывает список переменных окружения, которые
# НЕ НАДО передавать в эту команду
#
proc custom_client {command {forbidden_vars {}}} {
	set ::test::client_app $command
	set ::test::client_unset $forbidden_vars

}
#
# Восстанавливает станадртую клиентскую команду
#
proc our_client {} {
	catch {unset ::test::client_app}
	catch {unset ::test::client_unset}
}	

#
# Закрывает файл, указанный в соответствующем file_id, возвращает
# элемент глобального массива output, содержимое error message от close
# и код завершения процесса (имя сигнала)
proc stop {file_id} {
	global output
	fconfigure $file_id -blocking yes
	if {[catch {close $file_id} msg]} {
		if {[string match CHILD* [lindex $::errorCode 0]]} {
			set status [lindex $::errorCode 2]
		} else {
			set status 0
		}	
	}  else {
		set status 0
	}	
	return [list $output($file_id) $msg $status]
}	
#
# Завершает работу сервера
#
proc stop_server {file_id} {
#	puts $file_id "Q\n" 
#	catch {set xx [socket localhost 4433]}
	log "Interrupting process [pid $file_id]"
	flush [test_log]
	kill INT [pid $file_id]
	#puts -nonewline stderr "Waiting for server termination.."
	vwait finished($file_id)
	if [info exists xx] {close $xx}
#	puts stderr "Ok"
}	

#
# Запускает процесс с указанной командной строкой. Возвращает дескриптор
# файла в nonblocking mode с повешенным туда fileevent
# Очищает соответствующие элементы массивов output и finished
proc start_process {cmd_line read_event {mode "r"}} {
	set f [open "|$cmd_line" $mode]
	global output finished
	catch {unset finished($f)}
	fconfigure $f -buffering none -blocking n
	set output($f) ""
	fileevent $f readable [list $read_event $f]
	return $f
}	
#
# Обработчик fileevent-ов на чтение. Записывает считанные данные в
# элемент массива output соответствущий файлхендлу. В случае если
# достигнут eof, выставляет элемент массива finished. (элемент output
# при этом тоже трогается, чтобы vwait завершился)
#
proc process_read {f} {
	global output
	if {[eof $f]} {
		global finished
		fconfigure $f -blocking y
		set finished($f) 1
		append output($f) ""
		return
	}	
	append output($f) [read $f]
}	

#
#  Запускает openssl s_server с указанными аргументами и дожидается пока
#  он скажет на stdout ACCEPT. Возвращает filehandle, открытый на
#  чтение/запись
#
proc open_server {server_args} {
	global OPENSSL_APP
	global ENGINE_PATH
	if {[info exists ::test::server_conf]} {
		global env
		set save_conf $env(OPENSSL_CONF)
		set env(OPENSSL_CONF) $::test::server_conf
	}
	if {[info exists ::test::server_app]} {
		set server $::test::server_app
	} else {
		set server [list $OPENSSL_APP s_server]
	}
	if {[info exists ::test::server_unset]} {
		save_env $::test::server_unset
	}	
	set server [start_process [concat $server $server_args] process_read "r+"]
	restore_env
	if {[info exists save_conf]} {
		set env(OPENSSL_CONF) $save_conf
	}	

	global output finished
	#puts -nonewline stderr  "Waiting for server startup..."
	while {![regexp "\nACCEPT\n" $output($server)]} {
		vwait output($server)
		if {[info exists finished($server)]} {
			#puts stderr "error"
			return -code error [lindex  [stop $server] 1]
		}	
	}		
	#puts stderr "Ok"
	after 100
	return $server
}
#
# Сохраняет указанные переменные среды для последующего восстановления
# restore_env
#
proc save_env {var_list} {
	catch {array unset ::test::save_env}
	foreach var $var_list {
		if {[info exist ::env($var)]} {
			set ::test::save_env($var) $::env($var)
			unset ::env($var)
		}	
	}

}
proc restore_env {} {
	if {[array exists ::test::save_env]} {
		array set ::env [array get ::test::save_env]
		array unset ::test::save_env
	}	
	
}
#
# Сохраняет указанные переменные среды для последующего восстановления
# restore_env2. В отличие от save_env, не делает unset сохраненной переменной.
#
proc save_env2 {var_list} {
	catch {array unset ::test::save_env2}
	foreach var $var_list {
		if {[info exist ::env($var)]} {
			set ::test::save_env2($var) $::env($var)
		}	
	}

}
#
# Восстанавливает переменные среды, ранее сохраненные функцией save_env2 
# В отличие от функции restore_env, требует списка переменных и 
# восстанавливает только переменные из данного списка. Второе отличие -
# если переменная из списка не была сохранена, делает ей unset.
#
proc restore_env2 {var_list} {
	foreach var $var_list {
		if {[info exist ::test::save_env2($var)]} {
			set ::env($var) $::test::save_env2($var)
		} else {
			catch {unset ::env($var)}
		}
	}
	array unset ::test::save_env2
}


#
# Запускает s_client с указанными аргументами, передавая на stdin
# указанную строку
#
proc open_client {client_args client_stdin} {
	global OPENSSL_APP
	if [info exists ::test::client_app] {
		set client $::test::client_app
	} else {
		set client [list $OPENSSL_APP s_client]
	}
	if {[info exists ::test::client_unset]} {
		save_env $::test::client_unset
	}	
	if {[info exists ::test::client_conf]}  {
		set save_env(OPENSSL_CONF) $::env(OPENSSL_CONF)
		set ::env(OPENSSL_CONF) $::test::client_conf
	}
	set client [start_process [concat $client $client_args [list << $client_stdin]] process_read]
	restore_env
	return $client
}	
#
# Зачитывает список хостов из ../../ssl-ciphers
#
proc get_hosts {file} {
	set ::test::suffix "-$file"
	if [file readable $file.ciphers] {
		set f [open $file.ciphers]
	} else {	
		set f [open ../../ssl-ciphers/$file.ciphers r]
	}
	while {[gets $f line]>=0} {
		if {[regexp {^\s*#} $line]} continue
		append data "$line\n"
	}
	close $f
	global hosts
	array set hosts $data
}	
#
# Регистрирует пользователся (возможно удаленном) тестовом CA, используя
# скрипт testca установленный в PATH на CAhost.
#

proc registerUserAtCA {userdir CAhost CAprefix CApath} {
		global OPENSSL_APP
		log "registerUserAtCA $userdir $CAhost $CAprefix $CApath"
		set f [open  $userdir/req.pem]
		set request [read $f]
		close $f
		set token [::http::geturl http://$CAhost/$CAprefix/$CApath\
		-query [::http::formatQuery request $request startdate [clock\
		format [expr [clock seconds]-3600] -format "%y%m%d%H%M%SZ" -gmt y]]]
		if {[::http::ncode $token]!=200} {
			return -code error "Error certifying request [::http::data $token]"
		}
		log "Got a certificate. Saving"
		saveCertFromPKCS7 $userdir/cert.pem [::http::data $token]
}
proc saveCertFromPKCS7 {file pkcs7} {
		global OPENSSL_APP
		log saveCertFromPCS7
		log "$OPENSSL_APP pkcs7 -print_certs $pkcs7"
		set f [open "|[list $OPENSSL_APP pkcs7 -print_certs << $pkcs7]" r]
		set out [open $file w]
		set mode 0
		while {[gets $f line]>=0} {
			if {$mode==1} {
				puts $out $line
				if {$line eq "-----END CERTIFICATE-----"} {
					set mode 2
				}
			} elseif {$mode==0 && $line eq "-----BEGIN CERTIFICATE-----"} {
				set mode 1
				puts $out $line
			}
		}	
		close $f
		close $out
		if {$mode !=2 } {
			return -code error "Cannot get certificate from PKCS7 output"
		}	
}
#
# Invokes scp and discards stderr output if exit code is 0
#
proc scp {args} {
	if {[info exists env(SCP)]} {
		set scp $env(SCP)
	} else {
		set scp scp
	}	
	if {[catch [concat exec $scp $args] msg]} {
		if {[string match CHIDLD* [lindex $::errorCode 0]]} {
			return -code error -errorcode $::errorCode  $msg
		}
	}
}	

proc getCAAlgParams {CAhost CAprefix alg} {
 	if {$alg == "ec" || $alg == "dsa"} {
		set token [::http::geturl http://$CAhost/$CAprefix/$alg?algparams=1]
		if {[::http::ncode $token]!=200} {
			return -code error "Error getting algorithm parameters [::http::data $token]"
		}
		set f [open ${alg}params.pem w]
		puts $f [::http::data $token]
		close $f
	}
}	
#
# Copies CA certificate from specified CA into ca_$alg.pem
# Returns name of the ca certificate or empty line if something goes
# wrong and error wasn't properly detected
#
proc getCAcert {CAhost CApath alg} {
	set token [::http::geturl http://$CAhost$CApath/$alg?getroot=1]
	if {[::http::ncode $token]!=200} {
		return -code error "Error getting root cert for $alg: [::http::data $token]"
	}
	saveCertFromPKCS7 ca_$alg.pem [::http::data $token]	
	return ca_$alg.pem
}
#
# Returns decoded version of first pem object in the given file
#
proc readpem {filename} {
	set f [open $filename]
	fconfigure $f -translation binary
	set data [read $f]
	close $f
	if {[regexp -- "-----BEGIN \[^\n\]+-----\r?\n(.*\n)-----END" $data => b64]} {
		set data [::base64::decode $b64]
	}  
	return $data

}
	
proc der_from_pem {pem} {
	if {[regexp -- {^-----BEGIN ([^\n]*)-----\r?\n(.*)\r?\n-----END \1-----} $pem => => base64]} {
		::base64::decode $base64
	} {
		error "Not a PEM:\n$pem"
	}
}

proc engine_name {} {
	global env
	if {[info exists env(ENGINE_NAME)]} {
		switch -exact $env(ENGINE_NAME) {
			"open" {return "open"}
			"gost" {return "open"}
			"cryptocom" {return "ccore"}
			"ccore" {return "ccore"}
			default {error "Unknown engine '$env(ENGINE_NAME)'"}
		}
	} else {
		return "ccore"
	}
}

proc openssl_remote {files host cmdlinex suffix} {
		set hostname [exec hostname]
		set workpath /tmp/$hostname/$suffix
		save_env {LD_LIBRARY_PATH OPENSSL_CONF ENGINE_DIR}
		exec ssh build@$host mkdir -p $workpath
		foreach file $files {
			exec scp -r $file build@$host:$workpath
		}
		exec scp ../opnssl.sh build@$host:$workpath
		exec ssh build@$host chmod +x $workpath/opnssl.sh
		set cmdline [string map "TESTPATH $workpath" $cmdlinex]
		log "hstname: $hostname OpenSSL cmdline: $host remote_openssl $cmdline"
		set f [open "| ssh build@$host $workpath/opnssl.sh $cmdline" r]
		set output [read $f]
		restore_env
		if {[catch {close $f} msg]} {
			append output "STDERR CONTENTS:\n$msg"
			log $output
			if {[lindex $::errorCode 0]!="NONE"} {
				return -code error -errorcode $::errorCode $output
			}
		}
		return $output
}

package provide ossltest 0.7