#
    # X.509v3 Certificate Viewer
    #
    # (c) 2004 Michael Schlenker <[email protected]>
    #
    # License: like tcllib
    #
    #
    # This implements an incomplete certificate viewer for 
    # X.509v3 Certificates stored in the PEM Format used by openssl.
    #
    #
    #

    package require base64
    package require asn
    package require textutil

    #
    # Some (incomplete) OID -> Name mappings from RFC 3279, 3280 and the X.500
    #
    #
    # attribute names under OID 2.5.4.x
    set attributeType {
                  objectClass 
                  aliasedEntryName  
                  knowledgeInformation
                  commonName
                  surname
                  serialNumber
                  countryName
                  localityName
                  stateOrProvinceName
                  streetAddress
                  organizationName
                  organizationUnitName
                  title
                  description
                  searchGuide
                  businessCategory
                  postalAddress
                  postalCode
                  postOfficeBox
                  physicalDeliveryOfficeName
                  telephoneNumber
                  telexNumber
                  teletexTerminalIdentifier
                  facsimileTelephoneNumber
                  x121Address
                  internationalISDNNumber
                  registeredAddress
                  destinationIndicator
                  preferredDeliveryMethod
                  presentationAddress
                  supportedApplicationContext
                  member
                  owner
                  roleOccupant
                  seeAlso
                  userPassword
                  userCertificate
                  cAcertificate
                  authorityRevocationList
                  certificateRevocationList
                  crossCertificatePair
                  name
                  givenName
                  initials
                  generationQualifier
                  uniqueIdentifier
                  dnQualifier
                  enhancedSearchGuide
                  protocolInformation
                  distinguishedName
                  uniqueMember
                  houseIdentifier
                  supportedAlgorithms
                  deltaRevocationList
                  dmdName
                  clearance
                  defaultDirQop
                  attributeIntegrityInfo
                  attributeCertificate
                  attributeCertificateRevocationList
                  confKeyInfo
                  aACertificate
                  attributeDescriptorCertificate
                  attributeAuthorityRevocationList
                  family-information
                  pseudonym
                  communicationsService
                  communicationsNetwork
                  certificationPracticeStmt
                  certificatePolicy
                  pkiPath
                  privPolicy
                  role
    }

    array set algorithms {
        {1 2 840 113549 2} md2
        {1 2 840 113549 5} md5
        {1 3 14 3 2 26} sha1
        {1 2 840 10040 4 1} dsa
        {1 2 840 10040 4 3} dsa-with-sha1
        {1 2 840 113549 1 1} "pkcs-1 oid arc"
        {1 2 840 113549 1 1 1} rsa
        {1 2 840 113549 1 1 2} md2-with-rsa
        {1 2 840 113549 1 1 4} md5-with-rsa
        {1 2 840 113549 1 1 5} sha1-with-rsa
        {1 2 840 10046 2 1} Diffie-Hellman
    }

    #####################################################################
    # 
    # Actual Parsing Code starts here
    #
    #####################################################################


    proc load_cert {filename} {

        set fd [open $filename]
        set data [read $fd]
        close $fd

        set lines [split $data \n]
        set hlines 0
        set total 0
        set headers ""
        set head_banner ""
        set foot_banner ""
        set first 0
        foreach line $lines {
            incr total
            if {[regexp {^-----(.*?)-----$} $line -> banner]} {
                if {$first} {
                    set foot_banner $banner
                    incr total -1
                    break
                } else {
                    set first 1
                    set head_banner $banner
                    incr hlines
                }
            }        
            if {[regexp {^(.*):(.*)$} $line -> tag value]} {
                lappend headers [list $tag $value]
                incr hlines
            } 
        }
        set block [join [lrange $lines $hlines [expr {$total-1}]]]
        set asnblock [base64::decode $block]
        return [list $head_banner $headers $asnblock $foot_banner]
    }

    proc parse_cert {asnblock} {
        puts "Parsing Certificate..."
        asn::asnGetSequence asnblock certificate
        asn::asnGetSequence certificate TBSCertificate
        parse_TBSCertificate $TBSCertificate

        asn::asnGetSequence certificate AlgorithmIdentifier
        parse_AlgorithmIdentifier $AlgorithmIdentifier
        asn::asnGetBitString certificate Signature
        set len [string length $Signature]
        if {($len % 8)==0} {
            binary scan [binary format B* $Signature] H* sig
            puts "Signature ($len bits):"
            puts [textutil::adjust $sig -strictlength 1 -length 67]
        } else {
            puts "Signature ($len bits):"
            puts [textutil::adjust $Signature -strictlength 1 -length 67]
        }
    }

    proc parse_AlgorithmIdentifier {asnblock} {
        asn::asnGetObjectIdentifier asnblock oid
        set name [map_oid_to_name $oid]
        # skipping the parameter for now
        return [list $name $oid]
    }

    proc parse_TBSCertificate {asnblock} {
        puts [string repeat - 72 ]
        set check [string index $asnblock 0] 
        if {![catch {asn::asnGetContext check tag}]} {        
            asn::asnGetContext asnblock context
            asn::asnGetInteger asnblock version
        } else {
            set version 0
        }
        set versionID [list v1 v2 v3]
        puts [format "Certificate Version            :\t%s" [lindex $versionID $version]]
        # homegrown getInteger for the 20octet ints in serial number
        asn::asnGetByte asnblock tag
        asn::asnGetLength asnblock len
        asn::asnGetBytes asnblock $len ser
        binary scan $ser H* serialNumber
        puts [format "Certificate Serial Number      :\t%s" $serialNumber]
        asn::asnGetSequence asnblock Algorithm
        foreach {name oid} [parse_AlgorithmIdentifier $Algorithm] {break}
        puts [format "Certificate Signature Algorithm:\t%s <urn:oid:%s>" $name [join $oid .]]
        startbanner Issuer
        asn::asnGetSequence asnblock Issuer
        parse_RelativeDistinguishedName $Issuer
        endbanner
        asn::asnGetSequence asnblock Validity
        parse_Validity $Validity
        startbanner Subject
        asn::asnGetSequence asnblock Subject
        parse_RelativeDistinguishedName $Subject
        endbanner
        asn::asnGetSequence asnblock SubjectPublicKeyInfo
        parse_SubjectPublicKeyInfo $SubjectPublicKeyInfo
        while {[string length $asnblock]} {
            asn::asnGetContext asnblock context
            switch -exact -- $context {
                0 { error "Context Tag for Version Number found in wrong place"}
                1 { 
                    puts "Issuer Unique Identifier:"
                    asn::asnGetBitstring asnblock IssuerUniqueIdentifier
                    puts $IssuerUniqueIdentifier
                }
                2 { 
                    puts "Subject Unique Identifier:"
                    asn::asnGetBitstring asnblock SubjectUniqueIdentifier
                    puts $SubjectUniqueIdentifier
                }
                3 { 
                    asn::asnGetSequence asnblock Extension
                    parse_Extension $Extension

                }
            }
        }

    }

    proc parse_Extension {asnblock} {
        startbanner Extension
        asn::asnGetSequence asnblock extension
        asn::asnGetObjectIdentifier extension oid
        puts "Extension OID: $oid"
        binary scan [string index $extension 0] c c
        if {$c == 0x01} {
            asn::asnGetBoolean extension critical
            puts "Is Critical: [expr {$critical ? "yes" : "no"}]"
        }
        asn::asnGetOctetString extension value
        puts "Extension Value:"
        binary scan $value H* bin
        puts $bin
        endbanner
    }

    proc parse_SubjectPublicKeyInfo {asnblock} {
        startbanner "SubjectPublicKey"
        asn::asnGetSequence asnblock Algorithm
        foreach {name oid} [parse_AlgorithmIdentifier $Algorithm] {break}
        puts [format "PublicKey Algorithm:\t%s <urn:oid:%s>" $name [join $oid .]]

        asn::asnGetBitString asnblock publicKey
        set len [string length $publicKey]
        if {($len % 8)==0} {
            binary scan [binary format B* $publicKey] H* key
            puts "Key ($len bits):"
            puts [textutil::adjust $key -strictlength 1 -length 67 ]
        } else {
            puts "Key ($len bits):"
            puts [textutil::adjust $publicKey -strictlength 1 -length 67]
        }
        endbanner

    }

    proc parse_Validity {asnblock} {
        startbanner Validity
        asn::asnGetUTCTime asnblock notBefore
        puts "Valid not before: $notBefore"
        asn::asnGetUTCTime asnblock notAfter
        puts "Valid not after:  $notAfter"
        endbanner
    }

    proc parse_RelativeDistinguishedName {asnblock} {
        while {[string length $asnblock]} {
            asn::asnGetSet asnblock AttributeValueAssertion
            asn::asnGetSequence AttributeValueAssertion valblock
            asn::asnGetObjectIdentifier valblock oid
            set name [map_oid_to_name $oid]
            set poid [join $oid .]
            set tagbyte [string index $valblock 0]
            binary scan $tagbyte c* dectag
            set value ""
            if {$dectag == 19} {
                asn::asnGetPrintableString valblock value
            }
            puts "$name <urn:oid:$poid> => $value"
        }
    }

    #################################################################################
    #
    # Extra ASN.1 BER/DER Decoders not yet supported in tcllib asn v0.1
    #
    #################################################################################

    proc asn::asnGetBoolean {data_var bool_var} {
        upvar $data_var data $bool_var bool

        asnGetByte data tag
        if {$tag != 0x01} {
            binary scan $tag H2 tag_hex
            return -code error "Expected Boolean (0x01), but got $tag_hex"
        }
        asnGetLength data length
        asnGetByte data byte
        set bool [expr {$byte == 0 ? 0 : 1}]    
    }

    proc asn::asnGetUTCTime {data_var utc_var} {
        upvar $data_var data $utc_var utc

        asnGetByte data tag
        if {$tag != 0x17} {
            binary scan $tag H2 tag_hex
            return -code error "Expected UTCTime (0x17), but got $tag_hex"
        }
        asnGetLength data length
        asnGetBytes data $length bytes
        set bytes [encoding convertfrom ascii $bytes]
        binary scan $bytes a* utc

    }

    proc asn::asnGetBitString {data_var bitstring_var} {
        upvar $data_var data $bitstring_var bitstring

        asnGetByte data tag
        if {$tag != 0x03} {
            binary scan $tag H2 tag_hex
            return -code error "Expected Bit String (0x03), but got $tag_hex"
        }
        asnGetLength data length
        asnGetByte data offset
        incr length -1
        asnGetBytes data $length bytes
        binary scan $bytes B* bits
        set bits [string range $bits 0 end-$offset]
        set bitstring $bits
    }

    proc asn::asnGetObjectIdentifier {data_var oid_var} {
          upvar $data_var data $oid_var oid

          asnGetByte data tag
          if {$tag != 0x06} {
            binary scan $tag H2 tag_hex
            return -code error "Expected Object Identifier (0x06), but got $tag_hex"  
          }
          asnGetLength data length
          asnGetByte data val
          set oid [expr {$val / 40}]
          lappend oid [expr {$val % 40}]
          incr length -1
          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} {
            error "OID Data is incomplete, not enough octets."
          }
    }

    proc ::asn::asnGetContext {data_var contextNumber_var} {
        upvar $data_var data $contextNumber_var contextNumber

        asnGetByte   data tag
        asnGetLength data length

        if {($tag & 0xE0) != 0x0A0} {
            binary scan $tag H2 tag_hex
            return -code error "Expected Context (0xa0), but got $tag_hex"
        }    
        set contextNumber [expr {$tag & 0x1F}]
        return
    }

    proc ::asn::asnGetPrintableString {data_var print_var} {
        upvar $data_var data $print_var print

        asnGetByte data tag
        if {$tag != 0x13} {
            binary scan $tag H2 tag_hex
            return -code error "Expected Printable String (0x13), but got $tag_hex"  
        }
        asnGetLength data length 
        asnGetBytes data $length string
        set print [encoding convertfrom ascii $string]
    }

    ###########################################################################
    #
    # Some OID support routines
    #
    ###########################################################################

    proc is_oid_prefix {oid1 oid2} {
        foreach key1 $oid1 key2 [lrange $oid2 0 [expr {[llength $oid1]-1}]] {
            if {$key1 != $key2} {return 0}
            if {$key1 == ""} {return 1}
        }
        return 1
    }

    proc map_oid_to_name {oid} {
        global attributeType algorithms
        set name "unknown OID"
        if {[is_oid_prefix {2 5 4} $oid]} {
            set key [lindex $oid 3]
            set name [lindex $attributeType $key]
        }
        if {[is_oid_prefix {2 5 29 14} $oid]} {
        }
        if {[is_oid_prefix {1 2} $oid]} {
            if {[info exists algorithms($oid)]} {
                set name $algorithms($oid)
            } 
        }
        return $name
    }

    proc startbanner {text} {
        set len [expr {(70-[string length $text])/2}]
        puts "[string repeat = $len] $text \
              [string repeat = [expr {69-$len-[string length $text]}]]"
    }

    proc endbanner {} {
        puts [string repeat = 72]
    }

    # Main code
    #
    #
    #
    #
    set file [lindex $argv 0]
    puts "Loading and parsing $file"
    foreach {header headers asndata footer} [load_cert $file] {break}
    puts "Header: $header"
    foreach h $headers {
        puts "Header lines: $h"
    }
    puts "[string length $asndata] octets of ASN.1 Data"
    puts "Footer: $footer"
    puts "[string repeat - 72]"
    parse_cert $asndata