20040608 CMcC - This is the RSA crypto algorithm in pure tcl, requiring the bignum package.
package require bignum
# Key is an array with at least the following
# n - public modulus
# e - public exponent
# d - exponent
# and optionally these elements
# p - prime p.
# q - prime q.
# u - inverse of p mod q.
namespace eval rsa {
namespace import ::bigint::*
proc rsa_encrypt {input skey} {
upvar $skey key
if {[bitsize $key(n)] < [bitsize $input]} {
error "keysize [bitsize $key(n)] must be greater than text [bitsize $input]/$input"
}
return [powm $input $key(e) $key(n)]
}
# fast RSA decryption
# translated from gnupg
#
# ptext = ctext^d mod n
#
# Or faster:
#
# m1 = ctext ^ (d mod (p-1)) mod p
# m2 = ctext ^ (d mod (q-1)) mod q
# h = u * (m2 - m1) mod q
# ptext = m1 + h * p
#
# Where m is OUTPUT, c is INPUT and d,n,p,q,u are elements of SKEY.
proc rsa_decrypt {input skey} {
upvar $skey key
if {[bitsize $key(n)] < [bitsize $input]} {
error "keysize [bitsize $key(n)] must be greater than text [bitsize $input]/$input"
}
if {![info exists key(p)]} {
return [rsa_slow_decrypt $input key]
}
# m1 = c ^ (d mod (p-1)) mod p
set m1 [powm $input [fdiv_r $key(d) [sub_ui $key(p) 1]] $key(p)]
# m2 = c ^ (d mod (q-1)) mod q
set m2 [powm $input [fdiv_r $key(d) [sub_ui $key(q) 1]] $key(q)]
# h = u * ( m2 - m1 ) mod q
set h [sub $m2 $m1]
if {[cmp_si $h 0] < 0} {
set h [add $h $key(q)]
}
set h [fdiv_r [mul $key(u) $h] $key(q)]
# m = m2 + h * p
set m [add $m1 [mul $h $key(p)]]
return $m
}
# Public key operation. decrypt INPUT with PKEY and put result into OUTPUT.
#
# c = m^d mod n
#
# Where c is OUTPUT, m is INPUT and e,n are elements of PKEY.
proc rsa_slow_decrypt {input pkey} {
upvar $pkey key
if {[bitsize $key(n)] < [bitsize $input]} {
error "keysize [bitsize $key(n)] must be greater than text [bitsize $input]/$input"
}
if {[catch {set ptext [powm $input $key(d) $key(n)]}]} {
puts "rsa_slow_decrypt: $input [hex $key(d)] [hex $key(n)]"
error "powm error"
}
return $ptext
}
proc pack_text {ptext keylen} {
# pack ptext with md5
while {[string length $ptext] < ($keylen - 16)} {
append ptext [binary format H* [::md5::md5 $ptext]]
}
if {[string length $ptext] < $keylen} {
set md5 [binary format H* [::md5::md5 $ptext]]
append ptext [string range $md5 0 [expr $keylen - [string length $ptext] - 1]]
}
# convert the string to a hex number
binary scan $ptext H* hex
return [convert 0x$hex]
}
# encrypt a string - pad it out to full string size
proc encrypt {ptext pkey} {
upvar $pkey key
set keylen [bytesize $key(n)]
set en [pack_text $ptext $keylen]
set en [rsa_encrypt $en key]
append ctext [hex $en]
set ctext [binary format H* $ctext]
return $ctext
}
# encrypt a packet
# packet format: [md5][length][payload][padding]
proc encrypt_packet {ptext pkey} {
upvar $pkey key
set plen [binary format I [string length $ptext]]
set md5 [binary format H32 [::md5::md5 $ptext]]
set ptext ${md5}${plen}$ptext
return [encrypt $ptext key]
}
proc decrypt {ctext pkey} {
upvar $pkey key
set keylen [bytesize $key(n)]
binary scan $ctext H* block
append ptext [hex [rsa_decrypt 0x$block key]]
return [binary format H* $ptext]
}
# decrypt a packet
# packet format: [md5][length][payload][padding]
proc decrypt_packet {ctext pkey} {
upvar $pkey key
set ptext [decrypt $ctext key]
binary scan $ptext a16I md5 plen
set ptext [string range $ptext 20 end]
set ptext [string range $ptext 0 [expr $plen - 1]]
set md5calc [binary format H* [::md5::md5 $ptext]]
if {$md5calc != $md5} {
error "packet checksum failed $md5calc != $md5: $plen / $ptext"
}
return $ptext
}
namespace export encrypt* decrypt*
}
# gpg --gen-key --debug=4Here is a test of the rsa package:
array set key {
name sample5
e 0x010001
d 0x036C3A32890E163000E25FAC522E1B3BAB6086837E6EF01CADCB4AA6DBDF0267D695FABA49ABB04B359E051DCE72FC377FE5C999D79D543861938233481E0D49D1
n 0x057CA8F6CA506C64FC8BB83482F6EDD6C9AF6EF2EB235217680F7B76072CE320196355C89C0670B37D6F294FA4817EE1E7022566F17C8FB24C8B5ADA1A9BA115A7
}
do_key
mod_tsts
set t "now is the winter of our discontent"
set ct [rsa::encrypt $t key]
set pt [rsa::decrypt $ct key]
puts $pt