diff options
Diffstat (limited to 'tcllib/modules/asn/asn.tcl')
| -rw-r--r-- | tcllib/modules/asn/asn.tcl | 1580 |
1 files changed, 1580 insertions, 0 deletions
diff --git a/tcllib/modules/asn/asn.tcl b/tcllib/modules/asn/asn.tcl new file mode 100644 index 0000000..cca460a --- /dev/null +++ b/tcllib/modules/asn/asn.tcl @@ -0,0 +1,1580 @@ +#----------------------------------------------------------------------------- +# Copyright (C) 1999-2004 Jochen C. Loewer (loewerj@web.de) +# Copyright (C) 2004-2011 Michael Schlenker (mic42@users.sourceforge.net) +#----------------------------------------------------------------------------- +# +# A partial ASN decoder/encoder implementation in plain Tcl. +# +# See ASN.1 (X.680) and BER (X.690). +# See 'asn_ber_intro.txt' in this directory. +# +# This software is copyrighted by Jochen C. Loewer (loewerj@web.de). The +# following terms apply to all files associated with the software unless +# explicitly disclaimed in individual files. +# +# The authors hereby grant permission to use, copy, modify, distribute, +# and license this software and its documentation for any purpose, provided +# that existing copyright notices are retained in all copies and that this +# notice is included verbatim in any distributions. No written agreement, +# license, or royalty fee is required for any of the authorized uses. +# Modifications to this software may be copyrighted by their authors +# and need not follow the licensing terms described here, provided that +# the new terms are clearly indicated on the first page of each file where +# they apply. +# +# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. +# +# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +# MODIFICATIONS. +# +# written by Jochen Loewer +# 3 June, 1999 +# +# $Id: asn.tcl,v 1.20 2011/01/05 22:33:33 mic42 Exp $ +# +#----------------------------------------------------------------------------- + +# needed for using wide() +package require Tcl 8.4 + +namespace eval asn { + # Encoder commands + namespace export \ + asnSequence \ + asnSequenceFromList \ + asnSet \ + asnSetFromList \ + asnApplicationConstr \ + asnApplication \ + asnContext\ + asnContextConstr\ + asnChoice \ + asnChoiceConstr \ + asnInteger \ + asnEnumeration \ + asnBoolean \ + asnOctetString \ + asnNull \ + asnUTCTime \ + asnNumericString \ + asnPrintableString \ + asnIA5String\ + asnBMPString\ + asnUTF8String\ + asnBitString \ + asnObjectIdentifer + + # Decoder commands + namespace export \ + asnGetResponse \ + asnGetInteger \ + asnGetEnumeration \ + asnGetOctetString \ + asnGetSequence \ + asnGetSet \ + asnGetApplication \ + asnGetNumericString \ + asnGetPrintableString \ + asnGetIA5String \ + asnGetBMPString \ + asnGetUTF8String \ + asnGetObjectIdentifier \ + asnGetBoolean \ + asnGetUTCTime \ + asnGetBitString \ + asnGetContext + + # general BER utility commands + namespace export \ + asnPeekByte \ + asnGetLength \ + asnRetag \ + asnPeekTag \ + asnTag + +} + +#----------------------------------------------------------------------------- +# Implementation notes: +# +# See the 'asn_ber_intro.txt' in this directory for an introduction +# into BER/DER encoding of ASN.1 information. Bibliography information +# +# A Layman's Guide to a Subset of ASN.1, BER, and DER +# +# An RSA Laboratories Technical Note +# Burton S. Kaliski Jr. +# Revised November 1, 1993 +# +# Supersedes June 3, 1991 version, which was also published as +# NIST/OSI Implementors' Workshop document SEC-SIG-91-17. +# PKCS documents are available by electronic mail to +# <pkcs@rsa.com>. +# +# Copyright (C) 1991-1993 RSA Laboratories, a division of RSA +# Data Security, Inc. License to copy this document is granted +# provided that it is identified as "RSA Data Security, Inc. +# Public-Key Cryptography Standards (PKCS)" in all material +# mentioning or referencing this document. +# 003-903015-110-000-000 +# +#----------------------------------------------------------------------------- + +#----------------------------------------------------------------------------- +# asnLength : Encode some length data. Helper command. +#----------------------------------------------------------------------------- + +proc ::asn::asnLength {len} { + + if {$len < 0} { + return -code error "Negative length octet requested" + } + if {$len < 128} { + # short form: ISO X.690 8.1.3.4 + return [binary format c $len] + } + # long form: ISO X.690 8.1.3.5 + # try to use a minimal encoding, + # even if not required by BER, but it is required by DER + # take care for signed vs. unsigned issues + if {$len < 256 } { + return [binary format H2c 81 [expr {$len - 256}]] + } + if {$len < 32769} { + # two octet signed value + return [binary format H2S 82 $len] + } + if {$len < 65536} { + return [binary format H2S 82 [expr {$len - 65536}]] + } + if {$len < 8388608} { + # three octet signed value + return [binary format H2cS 83 [expr {$len >> 16}] [expr {($len & 0xFFFF) - 65536}]] + } + if {$len < 16777216} { + # three octet signed value + return [binary format H2cS 83 [expr {($len >> 16) -256}] [expr {($len & 0xFFFF) -65536}]] + } + if {$len < 2147483649} { + # four octet signed value + return [binary format H2I 84 $len] + } + if {$len < 4294967296} { + # four octet unsigned value + return [binary format H2I 84 [expr {$len - 4294967296}]] + } + if {$len < 1099511627776} { + # five octet unsigned value + return [binary format H2 85][string range [binary format W $len] 3 end] + } + if {$len < 281474976710656} { + # six octet unsigned value + return [binary format H2 86][string range [binary format W $len] 2 end] + } + if {$len < 72057594037927936} { + # seven octet value + return [binary format H2 87][string range [binary format W $len] 1 end] + } + + # must be a 64-bit wide signed value + return [binary format H2W 88 $len] +} + +#----------------------------------------------------------------------------- +# asnSequence : Assumes that the arguments are already ASN encoded. +#----------------------------------------------------------------------------- + +proc ::asn::asnSequence {args} { + asnSequenceFromList $args +} + +proc ::asn::asnSequenceFromList {lst} { + # The sequence tag is 0x30. The length is arbitrary and thus full + # length coding is required. The arguments have to be BER encoded + # already. Constructed value, definite-length encoding. + + set out "" + foreach part $lst { + append out $part + } + set len [string length $out] + return [binary format H2a*a$len 30 [asnLength $len] $out] +} + + +#----------------------------------------------------------------------------- +# asnSet : Assumes that the arguments are already ASN encoded. +#----------------------------------------------------------------------------- + +proc ::asn::asnSet {args} { + asnSetFromList $args +} + +proc ::asn::asnSetFromList {lst} { + # The set tag is 0x31. The length is arbitrary and thus full + # length coding is required. The arguments have to be BER encoded + # already. + + set out "" + foreach part $lst { + append out $part + } + set len [string length $out] + return [binary format H2a*a$len 31 [asnLength $len] $out] +} + + +#----------------------------------------------------------------------------- +# asnApplicationConstr +#----------------------------------------------------------------------------- + +proc ::asn::asnApplicationConstr {appNumber args} { + # Packs the arguments into a constructed value with application tag. + + set out "" + foreach part $args { + append out $part + } + set code [expr {0x060 + $appNumber}] + set len [string length $out] + return [binary format ca*a$len $code [asnLength $len] $out] +} + +#----------------------------------------------------------------------------- +# asnApplication +#----------------------------------------------------------------------------- + +proc ::asn::asnApplication {appNumber data} { + # Packs the arguments into a constructed value with application tag. + + set code [expr {0x040 + $appNumber}] + set len [string length $data] + return [binary format ca*a$len $code [asnLength $len] $data] +} + +#----------------------------------------------------------------------------- +# asnContextConstr +#----------------------------------------------------------------------------- + +proc ::asn::asnContextConstr {contextNumber args} { + # Packs the arguments into a constructed value with application tag. + + set out "" + foreach part $args { + append out $part + } + set code [expr {0x0A0 + $contextNumber}] + set len [string length $out] + return [binary format ca*a$len $code [asnLength $len] $out] +} + +#----------------------------------------------------------------------------- +# asnContext +#----------------------------------------------------------------------------- + +proc ::asn::asnContext {contextNumber data} { + # Packs the arguments into a constructed value with application tag. + set code [expr {0x080 + $contextNumber}] + set len [string length $data] + return [binary format ca*a$len $code [asnLength $len] $data] +} +#----------------------------------------------------------------------------- +# asnChoice +#----------------------------------------------------------------------------- + +proc ::asn::asnChoice {appNumber args} { + # Packs the arguments into a choice construction. + + set out "" + foreach part $args { + append out $part + } + set code [expr {0x080 + $appNumber}] + set len [string length $out] + return [binary format ca*a$len $code [asnLength $len] $out] +} + +#----------------------------------------------------------------------------- +# asnChoiceConstr +#----------------------------------------------------------------------------- + +proc ::asn::asnChoiceConstr {appNumber args} { + # Packs the arguments into a choice construction. + + set out "" + foreach part $args { + append out $part + } + set code [expr {0x0A0 + $appNumber}] + set len [string length $out] + return [binary format ca*a$len $code [asnLength $len] $out] +} + +#----------------------------------------------------------------------------- +# asnInteger : Encode integer value. +#----------------------------------------------------------------------------- + +proc ::asn::asnInteger {number} { + asnIntegerOrEnum 02 $number +} + +#----------------------------------------------------------------------------- +# asnEnumeration : Encode enumeration value. +#----------------------------------------------------------------------------- + +proc ::asn::asnEnumeration {number} { + asnIntegerOrEnum 0a $number +} + +#----------------------------------------------------------------------------- +# asnIntegerOrEnum : Common code for Integers and Enumerations +# No Bignum version, as we do not expect large Enums. +#----------------------------------------------------------------------------- + +proc ::asn::asnIntegerOrEnum {tag number} { + # The integer tag is 0x02 , the Enum Tag 0x0a otherwise identical. + # The length is 1, 2, 3, or 4, coded in a + # single byte. This can be done directly, no need to go through + # asnLength. The value itself is written in big-endian. + + # Known bug/issue: The command cannot handle very wide integers, i.e. + # anything above 8 bytes length. Use asnBignumInteger for those. + + # check if we really have an int + set num $number + incr num + + if {($number >= -128) && ($number < 128)} { + return [binary format H2H2c $tag 01 $number] + } + if {($number >= -32768) && ($number < 32768)} { + return [binary format H2H2S $tag 02 $number] + } + if {($number >= -8388608) && ($number < 8388608)} { + set numberb [expr {$number & 0xFFFF}] + set numbera [expr {($number >> 16) & 0xFF}] + return [binary format H2H2cS $tag 03 $numbera $numberb] + } + if {($number >= -2147483648) && ($number < 2147483648)} { + return [binary format H2H2I $tag 04 $number] + } + if {($number >= -549755813888) && ($number < 549755813888)} { + set numberb [expr {$number & 0xFFFFFFFF}] + set numbera [expr {($number >> 32) & 0xFF}] + return [binary format H2H2cI $tag 05 $numbera $numberb] + } + if {($number >= -140737488355328) && ($number < 140737488355328)} { + set numberb [expr {$number & 0xFFFFFFFF}] + set numbera [expr {($number >> 32) & 0xFFFF}] + return [binary format H2H2SI $tag 06 $numbera $numberb] + } + if {($number >= -36028797018963968) && ($number < 36028797018963968)} { + set numberc [expr {$number & 0xFFFFFFFF}] + set numberb [expr {($number >> 32) & 0xFFFF}] + set numbera [expr {($number >> 48) & 0xFF}] + return [binary format H2H2cSI $tag 07 $numbera $numberb $numberc] + } + if {($number >= -9223372036854775808) && ($number <= 9223372036854775807)} { + return [binary format H2H2W $tag 08 $number] + } + return -code error "Integer value to large to encode, use asnBigInteger" +} + +#----------------------------------------------------------------------------- +# asnBigInteger : Encode a long integer value using math::bignum +#----------------------------------------------------------------------------- + +proc ::asn::asnBigInteger {bignum} { + # require math::bignum only if it is used + package require math::bignum + + # this is a hack to check for bignum... + if {[llength $bignum] < 2 || ([lindex $bignum 0] ne "bignum")} { + return -code error "expected math::bignum value got \"$bignum\"" + } + if {[math::bignum::sign $bignum]} { + # generate two's complement form + set bits [math::bignum::bits $bignum] + set padding [expr {$bits % 8}] + set len [expr {int(ceil($bits / 8.0))}] + if {$padding == 0} { + # we need a complete extra byte for the sign + # unless this is a base 2 multiple + set test [math::bignum::fromstr 0] + math::bignum::setbit test [expr {$bits-1}] + if {[math::bignum::ne [math::bignum::abs $bignum] $test]} { + incr len + } + } + set exp [math::bignum::pow \ + [math::bignum::fromstr 256] \ + [math::bignum::fromstr $len]] + set bignum [math::bignum::add $bignum $exp] + set hex [math::bignum::tostr $bignum 16] + } else { + set bits [math::bignum::bits $bignum] + if {($bits % 8) == 0 && $bits > 0} { + set pad "00" + } else { + set pad "" + } + set hex $pad[math::bignum::tostr $bignum 16] + } + if {[string length $hex]%2} { + set hex "0$hex" + } + set octets [expr {(([string length $hex]+1)/2)}] + return [binary format H2a*H* 02 [asnLength $octets] $hex] +} + + +#----------------------------------------------------------------------------- +# asnBoolean : Encode a boolean value. +#----------------------------------------------------------------------------- + +proc ::asn::asnBoolean {bool} { + # The boolean tag is 0x01. The length is always 1, coded in + # a single byte. This can be done directly, no need to go through + # asnLength. The value itself is written in big-endian. + + return [binary format H2H2c 01 01 [expr {$bool ? 0x0FF : 0x0}]] +} + +#----------------------------------------------------------------------------- +# asnOctetString : Encode a string of arbitrary bytes +#----------------------------------------------------------------------------- + +proc ::asn::asnOctetString {string} { + # The octet tag is 0x04. The length is arbitrary, so we need + # 'asnLength' for full coding of the length. + + set len [string length $string] + return [binary format H2a*a$len 04 [asnLength $len] $string] +} + +#----------------------------------------------------------------------------- +# asnNull : Encode a null value +#----------------------------------------------------------------------------- + +proc ::asn::asnNull {} { + # Null has only one valid encoding + return \x05\x00 +} + +#----------------------------------------------------------------------------- +# asnBitstring : Encode a Bit String value +#----------------------------------------------------------------------------- + +proc ::asn::asnBitString {bitstring} { + # The bit string tag is 0x03. + # Bit strings can be either simple or constructed + # we always use simple encoding + + set bitlen [string length $bitstring] + set padding [expr {(8 - ($bitlen % 8)) % 8}] + set len [expr {($bitlen / 8) + 1}] + if {$padding != 0} { incr len } + + return [binary format H2a*cB* 03 [asnLength $len] $padding $bitstring] +} + +#----------------------------------------------------------------------------- +# asnUTCTime : Encode an UTC time string +#----------------------------------------------------------------------------- + +proc ::asn::asnUTCTime {UTCtimestring} { + # the utc time tag is 0x17. + # + # BUG: we do not check the string for well formedness + + set ascii [encoding convertto ascii $UTCtimestring] + set len [string length $ascii] + return [binary format H2a*a* 17 [asnLength $len] $ascii] +} + +#----------------------------------------------------------------------------- +# asnPrintableString : Encode a printable string +#----------------------------------------------------------------------------- +namespace eval asn { + variable nonPrintableChars {[^ A-Za-z0-9'()+,.:/?=-]} +} +proc ::asn::asnPrintableString {string} { + # the printable string tag is 0x13 + variable nonPrintableChars + # it is basically a restricted ascii string + if {[regexp $nonPrintableChars $string ]} { + return -code error "Illegal character in PrintableString." + } + + # check characters + set ascii [encoding convertto ascii $string] + return [asnEncodeString 13 $ascii] +} + +#----------------------------------------------------------------------------- +# asnIA5String : Encode an Ascii String +#----------------------------------------------------------------------------- +proc ::asn::asnIA5String {string} { + # the IA5 string tag is 0x16 + # check for extended charachers + if {[string length $string]!=[string bytelength $string]} { + return -code error "Illegal character in IA5String" + } + set ascii [encoding convertto ascii $string] + return [asnEncodeString 16 $ascii] +} + +#----------------------------------------------------------------------------- +# asnNumericString : Encode a Numeric String type +#----------------------------------------------------------------------------- +namespace eval asn { + variable nonNumericChars {[^0-9 ]} +} +proc ::asn::asnNumericString {string} { + # the Numeric String type has tag 0x12 + variable nonNumericChars + if {[regexp $nonNumericChars $string]} { + return -code error "Illegal character in Numeric String." + } + + return [asnEncodeString 12 $string] +} +#---------------------------------------------------------------------- +# asnBMPString: Encode a Tcl string as Basic Multinligval (UCS2) string +#----------------------------------------------------------------------- +proc asn::asnBMPString {string} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set bytes "" + foreach {lo hi} [split [encoding convertto unicode $string] ""] { + append bytes $hi $lo + } + } else { + set bytes [encoding convertto unicode $string] + } + return [asnEncodeString 1e $bytes] +} +#--------------------------------------------------------------------------- +# asnUTF8String: encode tcl string as UTF8 String +#---------------------------------------------------------------------------- +proc asn::asnUTF8String {string} { + return [asnEncodeString 0c [encoding convertto utf-8 $string]] +} +#----------------------------------------------------------------------------- +# asnEncodeString : Encode an RestrictedCharacter String +#----------------------------------------------------------------------------- +proc ::asn::asnEncodeString {tag string} { + set len [string length $string] + return [binary format H2a*a$len $tag [asnLength $len] $string] +} + +#----------------------------------------------------------------------------- +# asnObjectIdentifier : Encode an Object Identifier value +#----------------------------------------------------------------------------- +proc ::asn::asnObjectIdentifier {oid} { + # the object identifier tag is 0x06 + + if {[llength $oid] < 2} { + return -code error "OID must have at least two subidentifiers." + } + + # basic check that it is valid + foreach identifier $oid { + if {$identifier < 0} { + return -code error \ + "Malformed OID. Identifiers must be positive Integers." + } + } + + if {[lindex $oid 0] > 2} { + return -code error "First subidentifier must be 0,1 or 2" + } + if {[lindex $oid 1] > 39} { + return -code error \ + "Second subidentifier must be between 0 and 39" + } + + # handle the special cases directly + switch [llength $oid] { + 2 { return [binary format H2H2c 06 01 \ + [expr {[lindex $oid 0]*40+[lindex $oid 1]}]] } + default { + # This can probably be written much shorter. + # Just a first try that works... + # + set octets [binary format c \ + [expr {[lindex $oid 0]*40+[lindex $oid 1]}]] + foreach identifier [lrange $oid 2 end] { + set d 128 + if {$identifier < 128} { + set subidentifier [list $identifier] + } else { + set subidentifier [list] + # find the largest divisor + + while {($identifier / $d) >= 128} { + set d [expr {$d * 128}] + } + # and construct the subidentifiers + set remainder $identifier + while {$d >= 128} { + set coefficient [expr {($remainder / $d) | 0x80}] + set remainder [expr {$remainder % $d}] + set d [expr {$d / 128}] + lappend subidentifier $coefficient + } + lappend subidentifier $remainder + } + append octets [binary format c* $subidentifier] + } + return [binary format H2a*a* 06 \ + [asnLength [string length $octets]] $octets] + } + } + +} + +#----------------------------------------------------------------------------- +# asnGetResponse : Read a ASN response from a channel. +#----------------------------------------------------------------------------- + +proc ::asn::asnGetResponse {sock data_var} { + upvar 1 $data_var data + + # We expect a sequence here (tag 0x30). The code below is an + # inlined replica of 'asnGetSequence', modified for reading from a + # channel instead of a string. + + set tag [read $sock 1] + + if {$tag == "\x30"} { + # The following code is a replica of 'asnGetLength', modified + # for reading the bytes from the channel instead of a string. + + set len1 [read $sock 1] + binary scan $len1 c num + set length [expr {($num + 0x100) % 0x100}] + + if {$length >= 0x080} { + # The byte the read is not the length, but a prefix, and + # the lower nibble tells us how many bytes follow. + + set len_length [expr {$length & 0x7f}] + + # BUG: We should not perform the value extraction for an + # BUG: improper length. It wastes cycles, and here it can + # BUG: cause us trouble, reading more data than there is + # BUG: on the channel. Depending on the channel + # BUG: configuration an attacker can induce us to block, + # BUG: causing a denial of service. + set lengthBytes [read $sock $len_length] + + switch $len_length { + 1 { + binary scan $lengthBytes c length + set length [expr {($length + 0x100) % 0x100}] + } + 2 { binary scan $lengthBytes S length } + 3 { binary scan \x00$lengthBytes I length } + 4 { binary scan $lengthBytes I length } + default { + return -code error \ + "length information too long ($len_length)" + } + } + } + + # Now that the length is known we get the remainder, + # i.e. payload, and construct proper in-memory BER encoded + # sequence. + + set rest [read $sock $length] + set data [binary format aa*a$length $tag [asnLength $length] $rest] + } else { + # Generate an error message if the data is not a sequence as + # we expected. + + set tag_hex "" + binary scan $tag H2 tag_hex + return -code error "unknown start tag [string length $tag] $tag_hex" + } +} + +if {[package vsatisfies [package present Tcl] 8.5.0]} { +############################################################################## +# Code for 8.5 +############################################################################## +#----------------------------------------------------------------------------- +# asnGetByte (8.5 version) : Retrieve a single byte from the data (unsigned) +#----------------------------------------------------------------------------- + +proc ::asn::asnGetByte {data_var byte_var} { + upvar 1 $data_var data $byte_var byte + + binary scan [string index $data 0] cu byte + set data [string range $data 1 end] + + return +} + +#----------------------------------------------------------------------------- +# asnPeekByte (8.5 version) : Retrieve a single byte from the data (unsigned) +# without removing it. +#----------------------------------------------------------------------------- + +proc ::asn::asnPeekByte {data_var byte_var {offset 0}} { + upvar 1 $data_var data $byte_var byte + + binary scan [string index $data $offset] cu byte + + return +} + +#----------------------------------------------------------------------------- +# asnGetLength (8.5 version) : Decode an ASN length value (See notes) +#----------------------------------------------------------------------------- + +proc ::asn::asnGetLength {data_var length_var} { + upvar 1 $data_var data $length_var length + + asnGetByte data length + if {$length == 0x080} { + return -code error "Indefinite length BER encoding not yet supported" + } + if {$length > 0x080} { + # The retrieved byte is a prefix value, and the integer in the + # lower nibble tells us how many bytes were used to encode the + # length data following immediately after this prefix. + + set len_length [expr {$length & 0x7f}] + + if {[string length $data] < $len_length} { + return -code error \ + "length information invalid, not enough octets left" + } + + asnGetBytes data $len_length lengthBytes + + switch $len_length { + 1 { binary scan $lengthBytes cu length } + 2 { binary scan $lengthBytes Su length } + 3 { binary scan \x00$lengthBytes Iu length } + 4 { binary scan $lengthBytes Iu length } + default { + binary scan $lengthBytes H* hexstr + scan $hexstr %llx length + } + } + } + return +} + +} else { +############################################################################## +# Code for Tcl 8.4 +############################################################################## +#----------------------------------------------------------------------------- +# asnGetByte : Retrieve a single byte from the data (unsigned) +#----------------------------------------------------------------------------- + +proc ::asn::asnGetByte {data_var byte_var} { + upvar 1 $data_var data $byte_var byte + + binary scan [string index $data 0] c byte + set byte [expr {($byte + 0x100) % 0x100}] + set data [string range $data 1 end] + + return +} + +#----------------------------------------------------------------------------- +# asnPeekByte : Retrieve a single byte from the data (unsigned) +# without removing it. +#----------------------------------------------------------------------------- + +proc ::asn::asnPeekByte {data_var byte_var {offset 0}} { + upvar 1 $data_var data $byte_var byte + + binary scan [string index $data $offset] c byte + set byte [expr {($byte + 0x100) % 0x100}] + + return +} + +#----------------------------------------------------------------------------- +# asnGetLength : Decode an ASN length value (See notes) +#----------------------------------------------------------------------------- + +proc ::asn::asnGetLength {data_var length_var} { + upvar 1 $data_var data $length_var length + + asnGetByte data length + if {$length == 0x080} { + return -code error "Indefinite length BER encoding not yet supported" + } + if {$length > 0x080} { + # The retrieved byte is a prefix value, and the integer in the + # lower nibble tells us how many bytes were used to encode the + # length data following immediately after this prefix. + + set len_length [expr {$length & 0x7f}] + + if {[string length $data] < $len_length} { + return -code error \ + "length information invalid, not enough octets left" + } + + asnGetBytes data $len_length lengthBytes + + switch $len_length { + 1 { + # Efficiently coded data will not go through this + # path, as small length values can be coded directly, + # without a prefix. + + binary scan $lengthBytes c length + set length [expr {($length + 0x100) % 0x100}] + } + 2 { binary scan $lengthBytes S length + set length [expr {($length + 0x10000) % 0x10000}] + } + 3 { binary scan \x00$lengthBytes I length + set length [expr {($length + 0x1000000) % 0x1000000}] + } + 4 { binary scan $lengthBytes I length + set length [expr {(wide($length) + 0x100000000) % 0x100000000}] + } + default { + binary scan $lengthBytes H* hexstr + # skip leading zeros which are allowed by BER + set hexlen [string trimleft $hexstr 0] + # check if it fits into a 64-bit signed integer + if {[string length $hexlen] > 16} { + return -code error -errorcode {ARITH IOVERFLOW + {Length value too large for normal use, try asnGetBigLength}} \ + "Length value to large" + } elseif { [string length $hexlen] == 16 \ + && ([string index $hexlen 0] & 0x8)} { + # check most significant bit, if set we need bignum + return -code error -errorcode {ARITH IOVERFLOW + {Length value too large for normal use, try asnGetBigLength}} \ + "Length value to large" + } else { + scan $hexstr "%lx" length + } + } + } + } + return +} + +} + +#----------------------------------------------------------------------------- +# asnRetag: Remove an explicit tag with the real newTag +# +#----------------------------------------------------------------------------- +proc ::asn::asnRetag {data_var newTag} { + upvar 1 $data_var data + set tag "" + set type "" + set len [asnPeekTag data tag type dummy] + asnGetBytes data $len tagbytes + set data [binary format c* $newTag]$data +} + +#----------------------------------------------------------------------------- +# asnGetBytes : Retrieve a block of 'length' bytes from the data. +#----------------------------------------------------------------------------- + +proc ::asn::asnGetBytes {data_var length bytes_var} { + upvar 1 $data_var data $bytes_var bytes + + incr length -1 + set bytes [string range $data 0 $length] + incr length + set data [string range $data $length end] + + return +} + +#----------------------------------------------------------------------------- +# asnPeekTag : Decode the tag value +#----------------------------------------------------------------------------- + +proc ::asn::asnPeekTag {data_var tag_var tagtype_var constr_var} { + upvar 1 $data_var data $tag_var tag $tagtype_var tagtype $constr_var constr + + set type 0 + set offset 0 + asnPeekByte data type $offset + # check if we have a simple tag, < 31, which fits in one byte + + set tval [expr {$type & 0x1f}] + if {$tval == 0x1f} { + # long tag, max 64-bit with Tcl 8.4, unlimited with 8.5 bignum + asnPeekByte data tagbyte [incr offset] + set tval [expr {wide($tagbyte & 0x7f)}] + while {($tagbyte & 0x80)} { + asnPeekByte data tagbyte [incr offset] + set tval [expr {($tval << 7) + ($tagbyte & 0x7f)}] + } + } + + set tagtype [lindex {UNIVERSAL APPLICATION CONTEXT PRIVATE} \ + [expr {($type & 0xc0) >>6}]] + set tag $tval + set constr [expr {($type & 0x20) > 0}] + + return [incr offset] +} + +#----------------------------------------------------------------------------- +# asnTag : Build a tag value +#----------------------------------------------------------------------------- + +proc ::asn::asnTag {tagnumber {class UNIVERSAL} {tagstyle P}} { + set first 0 + if {$tagnumber < 31} { + # encode everything in one byte + set first $tagnumber + set bytes [list] + } else { + # multi-byte tag + set first 31 + set bytes [list [expr {$tagnumber & 0x7f}]] + set tagnumber [expr {$tagnumber >> 7}] + while {$tagnumber > 0} { + lappend bytes [expr {($tagnumber & 0x7f)+0x80}] + set tagnumber [expr {$tagnumber >>7}] + } + + } + + if {$tagstyle eq "C" || $tagstyle == 1 } {incr first 32} + switch -glob -- $class { + U* { ;# UNIVERSAL } + A* { incr first 64 ;# APPLICATION } + C* { incr first 128 ;# CONTEXT } + P* { incr first 192 ;# PRIVATE } + default { + return -code error "Unknown tag class \"$class\"" + } + } + if {[llength $bytes] > 0} { + # long tag + set rbytes [list] + for {set i [expr {[llength $bytes]-1}]} {$i >= 0} {incr i -1} { + lappend rbytes [lindex $bytes $i] + } + return [binary format cc* $first $rbytes ] + } + return [binary format c $first] +} + + + +#----------------------------------------------------------------------------- +# asnGetBigLength : Retrieve a length that can not be represented in 63-bit +#----------------------------------------------------------------------------- + +proc ::asn::asnGetBigLength {data_var biglength_var} { + + # Does any real world code really need this? + # If we encounter this, we are doomed to fail anyway, + # (there would be an Exabyte inside the data_var, ) + # + # So i implement it just for completeness. + # + package require math::bignum + + upvar 1 $data_var data $biglength_var length + + asnGetByte data length + if {$length == 0x080} { + return -code error "Indefinite length BER encoding not yet supported" + } + if {$length > 0x080} { + # The retrieved byte is a prefix value, and the integer in the + # lower nibble tells us how many bytes were used to encode the + # length data following immediately after this prefix. + + set len_length [expr {$length & 0x7f}] + + if {[string length $data] < $len_length} { + return -code error \ + "length information invalid, not enough octets left" + } + + asnGetBytes data $len_length lengthBytes + binary scan $lengthBytes H* hexlen + set length [math::bignum::fromstr $hexlen 16] + } + return +} + +#----------------------------------------------------------------------------- +# asnGetInteger : Retrieve integer. +#----------------------------------------------------------------------------- + +proc ::asn::asnGetInteger {data_var int_var} { + # Tag is 0x02. + + upvar 1 $data_var data $int_var int + + asnGetByte data tag + + if {$tag != 0x02} { + return -code error \ + [format "Expected Integer (0x02), but got %02x" $tag] + } + + asnGetLength data len + asnGetBytes data $len integerBytes + + set int ? + + switch $len { + 1 { binary scan $integerBytes c int } + 2 { binary scan $integerBytes S int } + 3 { + # check for negative int and pad + scan [string index $integerBytes 0] %c byte + if {$byte & 128} { + binary scan \xff$integerBytes I int + } else { + binary scan \x00$integerBytes I int + } + } + 4 { binary scan $integerBytes I int } + 5 - + 6 - + 7 - + 8 { + # check for negative int and pad + scan [string index $integerBytes 0] %c byte + if {$byte & 128} { + set pad [string repeat \xff [expr {8-$len}]] + } else { + set pad [string repeat \x00 [expr {8-$len}]] + } + binary scan $pad$integerBytes W int + } + default { + # Too long, or prefix coding was used. + return -code error "length information too long" + } + } + return +} + +#----------------------------------------------------------------------------- +# asnGetBigInteger : Retrieve a big integer. +#----------------------------------------------------------------------------- + +proc ::asn::asnGetBigInteger {data_var bignum_var} { + # require math::bignum only if it is used + package require math::bignum + + # Tag is 0x02. We expect that the length of the integer is coded with + # maximal efficiency, i.e. without a prefix 0x81 prefix. If a prefix + # is used this decoder will fail. + + upvar $data_var data $bignum_var bignum + + asnGetByte data tag + + if {$tag != 0x02} { + return -code error \ + [format "Expected Integer (0x02), but got %02x" $tag] + } + + asnGetLength data len + asnGetBytes data $len integerBytes + + binary scan [string index $integerBytes 0] H* hex_head + set head [expr 0x$hex_head] + set replacement_head [expr {$head & 0x7f}] + set integerBytes [string replace $integerBytes 0 0 [format %c $replacement_head]] + + binary scan $integerBytes H* hex + + set bignum [math::bignum::fromstr $hex 16] + + if {($head >> 7) && 1} { + set bigsub [math::bignum::pow [::math::bignum::fromstr 2] [::math::bignum::fromstr [expr {($len * 8) - 1}]]] + set bignum [math::bignum::sub $bignum $bigsub] + } + + return $bignum +} + + + + +#----------------------------------------------------------------------------- +# asnGetEnumeration : Retrieve an enumeration id +#----------------------------------------------------------------------------- + +proc ::asn::asnGetEnumeration {data_var enum_var} { + # This is like 'asnGetInteger', except for a different tag. + + upvar 1 $data_var data $enum_var enum + + asnGetByte data tag + + if {$tag != 0x0a} { + return -code error \ + [format "Expected Enumeration (0x0a), but got %02x" $tag] + } + + asnGetLength data len + asnGetBytes data $len integerBytes + set enum ? + + switch $len { + 1 { binary scan $integerBytes c enum } + 2 { binary scan $integerBytes S enum } + 3 { binary scan \x00$integerBytes I enum } + 4 { binary scan $integerBytes I enum } + default { + return -code error "length information too long" + } + } + return +} + +#----------------------------------------------------------------------------- +# asnGetOctetString : Retrieve arbitrary string. +#----------------------------------------------------------------------------- + +proc ::asn::asnGetOctetString {data_var string_var} { + # Here we need the full decoder for length data. + + upvar 1 $data_var data $string_var string + + asnGetByte data tag + if {$tag != 0x04} { + return -code error \ + [format "Expected Octet String (0x04), but got %02x" $tag] + } + asnGetLength data length + asnGetBytes data $length temp + set string $temp + return +} + +#----------------------------------------------------------------------------- +# asnGetSequence : Retrieve Sequence data for further decoding. +#----------------------------------------------------------------------------- + +proc ::asn::asnGetSequence {data_var sequence_var} { + # Here we need the full decoder for length data. + + upvar 1 $data_var data $sequence_var sequence + + asnGetByte data tag + if {$tag != 0x030} { + return -code error \ + [format "Expected Sequence (0x30), but got %02x" $tag] + } + asnGetLength data length + asnGetBytes data $length temp + set sequence $temp + return +} + +#----------------------------------------------------------------------------- +# asnGetSet : Retrieve Set data for further decoding. +#----------------------------------------------------------------------------- + +proc ::asn::asnGetSet {data_var set_var} { + # Here we need the full decoder for length data. + + upvar 1 $data_var data $set_var set + + asnGetByte data tag + if {$tag != 0x031} { + return -code error \ + [format "Expected Set (0x31), but got %02x" $tag] + } + asnGetLength data length + asnGetBytes data $length temp + set set $temp + return +} + +#----------------------------------------------------------------------------- +# asnGetApplication +#----------------------------------------------------------------------------- + +proc ::asn::asnGetApplication {data_var appNumber_var {content_var {}} {encodingType_var {}} } { + upvar 1 $data_var data $appNumber_var appNumber + + asnGetByte data tag + asnGetLength data length + + if {($tag & 0xC0) != 0x40} { + return -code error \ + [format "Expected Application, but got %02x" $tag] + } + if {$encodingType_var != {}} { + upvar 1 $encodingType_var encodingType + set encodingType [expr {($tag & 0x20) > 0}] + } + set appNumber [expr {$tag & 0x1F}] + if {[string length $content_var]} { + upvar 1 $content_var content + asnGetBytes data $length content + } + return +} + +#----------------------------------------------------------------------------- +# asnGetBoolean: decode a boolean value +#----------------------------------------------------------------------------- + +proc asn::asnGetBoolean {data_var bool_var} { + upvar 1 $data_var data $bool_var bool + + asnGetByte data tag + if {$tag != 0x01} { + return -code error \ + [format "Expected Boolean (0x01), but got %02x" $tag] + } + + asnGetLength data length + asnGetByte data byte + set bool [expr {$byte == 0 ? 0 : 1}] + return +} + +#----------------------------------------------------------------------------- +# asnGetUTCTime: Extract an UTC Time string from the data. Returns a string +# representing an UTC Time. +# +#----------------------------------------------------------------------------- + +proc asn::asnGetUTCTime {data_var utc_var} { + upvar 1 $data_var data $utc_var utc + + asnGetByte data tag + if {$tag != 0x17} { + return -code error \ + [format "Expected UTCTime (0x17), but got %02x" $tag] + } + + asnGetLength data length + asnGetBytes data $length bytes + + # this should be ascii, make it explicit + set bytes [encoding convertfrom ascii $bytes] + binary scan $bytes a* utc + + return +} + + +#----------------------------------------------------------------------------- +# asnGetBitString: Extract a Bit String value (a string of 0/1s) from the +# ASN.1 data. +# +#----------------------------------------------------------------------------- + +proc asn::asnGetBitString {data_var bitstring_var} { + upvar 1 $data_var data $bitstring_var bitstring + + asnGetByte data tag + if {$tag != 0x03} { + return -code error \ + [format "Expected Bit String (0x03), but got %02x" $tag] + } + + asnGetLength data length + # get the number of padding bits used at the end + asnGetByte data padding + incr length -1 + asnGetBytes data $length bytes + binary scan $bytes B* bits + + # cut off the padding bits + set bits [string range $bits 0 end-$padding] + set bitstring $bits +} + +#----------------------------------------------------------------------------- +# asnGetObjectIdentifier: Decode an ASN.1 Object Identifier (OID) into +# a Tcl list of integers. +#----------------------------------------------------------------------------- + +proc asn::asnGetObjectIdentifier {data_var oid_var} { + upvar 1 $data_var data $oid_var oid + + asnGetByte data tag + if {$tag != 0x06} { + return -code error \ + [format "Expected Object Identifier (0x06), but got %02x" $tag] + } + asnGetLength data length + + # the first byte encodes the OID parts in position 0 and 1 + asnGetByte data val + set oid [expr {$val / 40}] + lappend oid [expr {$val % 40}] + incr length -1 + + # the next bytes encode the remaining parts of the OID + set bytes [list] + set incomplete 0 + while {$length} { + asnGetByte data octet + incr length -1 + if {$octet < 128} { + set oidval $octet + set mult 128 + foreach byte $bytes { + if {$byte != {}} { + incr oidval [expr {$mult*$byte}] + set mult [expr {$mult*128}] + } + } + lappend oid $oidval + set bytes [list] + set incomplete 0 + } else { + set byte [expr {$octet-128}] + set bytes [concat [list $byte] $bytes] + set incomplete 1 + } + } + if {$incomplete} { + return -code error "OID Data is incomplete, not enough octets." + } + return +} + +#----------------------------------------------------------------------------- +# asnGetContext: Decode an explicit context tag +# +#----------------------------------------------------------------------------- + +proc ::asn::asnGetContext {data_var contextNumber_var {content_var {}} {encodingType_var {}}} { + upvar 1 $data_var data $contextNumber_var contextNumber + + asnGetByte data tag + asnGetLength data length + + if {($tag & 0xC0) != 0x80} { + return -code error \ + [format "Expected Context, but got %02x" $tag] + } + if {$encodingType_var != {}} { + upvar 1 $encodingType_var encodingType + set encodingType [expr {($tag & 0x20) > 0}] + } + set contextNumber [expr {$tag & 0x1F}] + if {[string length $content_var]} { + upvar 1 $content_var content + asnGetBytes data $length content + } + return +} + + +#----------------------------------------------------------------------------- +# asnGetNumericString: Decode a Numeric String from the data +#----------------------------------------------------------------------------- + +proc ::asn::asnGetNumericString {data_var print_var} { + upvar 1 $data_var data $print_var print + + asnGetByte data tag + if {$tag != 0x12} { + return -code error \ + [format "Expected Numeric String (0x12), but got %02x" $tag] + } + asnGetLength data length + asnGetBytes data $length string + set print [encoding convertfrom ascii $string] + return +} + +#----------------------------------------------------------------------------- +# asnGetPrintableString: Decode a Printable String from the data +#----------------------------------------------------------------------------- + +proc ::asn::asnGetPrintableString {data_var print_var} { + upvar 1 $data_var data $print_var print + + asnGetByte data tag + if {$tag != 0x13} { + return -code error \ + [format "Expected Printable String (0x13), but got %02x" $tag] + } + asnGetLength data length + asnGetBytes data $length string + set print [encoding convertfrom ascii $string] + return +} + +#----------------------------------------------------------------------------- +# asnGetIA5String: Decode a IA5(ASCII) String from the data +#----------------------------------------------------------------------------- + +proc ::asn::asnGetIA5String {data_var print_var} { + upvar 1 $data_var data $print_var print + + asnGetByte data tag + if {$tag != 0x16} { + return -code error \ + [format "Expected IA5 String (0x16), but got %02x" $tag] + } + asnGetLength data length + asnGetBytes data $length string + set print [encoding convertfrom ascii $string] + return +} +#------------------------------------------------------------------------ +# asnGetBMPString: Decode Basic Multiningval (UCS2 string) from data +#------------------------------------------------------------------------ +proc asn::asnGetBMPString {data_var print_var} { + upvar 1 $data_var data $print_var print + asnGetByte data tag + if {$tag != 0x1e} { + return -code error \ + [format "Expected BMP String (0x1e), but got %02x" $tag] + } + asnGetLength data length + asnGetBytes data $length string + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set str2 "" + foreach {hi lo} [split $string ""] { + append str2 $lo $hi + } + } else { + set str2 $string + } + set print [encoding convertfrom unicode $str2] + return +} +#------------------------------------------------------------------------ +# asnGetUTF8String: Decode UTF8 string from data +#------------------------------------------------------------------------ +proc asn::asnGetUTF8String {data_var print_var} { + upvar 1 $data_var data $print_var print + asnGetByte data tag + if {$tag != 0x0c} { + return -code error \ + [format "Expected UTF8 String (0x0c), but got %02x" $tag] + } + asnGetLength data length + asnGetBytes data $length string + #there should be some error checking to see if input is + #properly-formatted utf8 + set print [encoding convertfrom utf-8 $string] + + return +} +#----------------------------------------------------------------------------- +# asnGetNull: decode a NULL value +#----------------------------------------------------------------------------- + +proc ::asn::asnGetNull {data_var} { + upvar 1 $data_var data + + asnGetByte data tag + if {$tag != 0x05} { + return -code error \ + [format "Expected NULL (0x05), but got %02x" $tag] + } + + asnGetLength data length + asnGetBytes data $length bytes + + # we do not check the null data, all bytes must be 0x00 + + return +} + +#---------------------------------------------------------------------------- +# MultiType string routines +#---------------------------------------------------------------------------- + +namespace eval asn { + variable stringTypes + array set stringTypes { + 12 NumericString + 13 PrintableString + 16 IA5String + 1e BMPString + 0c UTF8String + 14 T61String + 15 VideotexString + 1a VisibleString + 1b GeneralString + 1c UniversalString + } + variable defaultStringType UTF8 +} +#--------------------------------------------------------------------------- +# asnGetString - get readable string automatically detecting its type +#--------------------------------------------------------------------------- +proc ::asn::asnGetString {data_var print_var {type_var {}}} { + variable stringTypes + upvar 1 $data_var data $print_var print + asnPeekByte data tag + set tag [format %02x $tag] + if {![info exists stringTypes($tag)]} { + return -code error "Expected one of string types, but got $tag" + } + asnGet$stringTypes($tag) data print + if {[string length $type_var]} { + upvar $type_var type + set type $stringTypes($tag) + } +} +#--------------------------------------------------------------------- +# defaultStringType - set or query default type for unrestricted strings +#--------------------------------------------------------------------- +proc ::asn::defaultStringType {{type {}}} { + variable defaultStringType + if {![string length $type]} { + return $defaultStringType + } + if {$type ne "BMP" && $type ne "UTF8"} { + return -code error "Invalid default string type. Should be one of BMP, UTF8" + } + set defaultStringType $type + return +} + +#--------------------------------------------------------------------------- +# asnString - encode readable string into most restricted type possible +#--------------------------------------------------------------------------- + +proc ::asn::asnString {string} { + variable nonPrintableChars + variable nonNumericChars + if {[string length $string]!=[string bytelength $string]} { + # There are non-ascii character + variable defaultStringType + return [asn${defaultStringType}String $string] + } elseif {![regexp $nonNumericChars $string]} { + return [asnNumericString $string] + } elseif {![regexp $nonPrintableChars $string]} { + return [asnPrintableString $string] + } else { + return [asnIA5String $string] + } +} + +#----------------------------------------------------------------------------- +package provide asn 0.8.4 + |