;; This is a partial implementation of the ASN.1 DER encoding rules.
;; Given an octet list, the procedure (DER:DECODE L) will decode the
;; list L, returning an appropriate Scheme type.
;;
;; Usage:
;;
;; (DER:DECODE der-encoded-value) => decoded-value
;; (DER:DECODE der-encoded-value ...) => decoded-value
;;
;; where DER-ENCODED-VALUE is a list of bytes, and DECODED-VALUE is
;; the corresponding value, as a suitable Scheme type, or #f on error.
;; The only exception to this 'suitable' rule is that ASN.1 booleans are
;; returned as either 'true or 'false, in order that the DER:DECODE procedure
;; is not specified to return #f on a value decode.
;;
;; The optional arguments are one of:
;; (include-tags )
;; Include tags in output
;; (translate-oids )
;; If true, then OIDs appearing in the output are displayed as strings rather
;; than symbols corresponding to the numeric OIDs
;; (save-error )
;; The is a procedure of one argument, which receives a string
;; which indicates an error message, in the event that decoding fails.
;;
;; Example:
;;
;; (der:decode '(#x13 #x0b #x54 #x65 #x73 #x74 #x20
;; #x55 #x73 #x65 #x72 #x20 #x31))
;; => "Test User 1"
;;
;; (der:decode '(#x13 #x0b #x54 #x65 #x73 #x74 #x20
;; #x55 #x73 #x65 #x72 #x20 #x31)
;; '(include-tags #t))
;; => '(printable-string . "Test User 1")
;;
;; If the DER-encoded value is malformed in some way, then DER:DECODE returns
;; #f. In this case, the 'save-error procedure is called with an
;; explanatory error message.
;;
;; The ASN.1 standard is X.680, available at
;;
;; The BER/CER/DER standard is X.690, at
;;
;;
;; See Burton S Kaliski's `A Layman's Guide to a Subset of ASN.1,
;; BER, and DER'. See , or
;; for an HTML version.
;;
;; The set of types implemented is the set used by X.509 certificates,
;; as described in Kalinski's paper. Most of the test cases below
;; are taken from there, too.
;;
;; Uses SRFI-8 (receive multiple values) and SRFI-60 (integers as bits).
;; It also uses the not-quite-portable FORMAT function, which it abstracts
;; in syntactic sugar as the syntax SFORMAT (see the configuration section
;; below).
;;
;;
;; CONFIGURATION
;;
;; This file is distributed with support for the required SRFIs and the
;; SFORMAT sugar indicated for a couple of Scheme implementations,
;; but commented out (search for the string @CONFIG@).
;; Uncomment as appropriate, with for example
;; % cat >decode-der-mzscheme
;; #!/bin/sh -
;; #|
;; exec mzscheme -f "$0" ${1+"$@"}
;; |#
;; (define (main args)
;; (let loop ((bytes #"")
;; (new-bytes (read-bytes 1024)))
;; (if (eof-object? new-bytes)
;; (display (der:decode (bytes->list bytes)))
;; (loop (bytes-append bytes new-bytes)
;; (read-bytes 1024)))))
;; % sed 's/^;@CONFIG mzscheme@//' decode-der.scm >>decode-der-mzscheme
;; % chmod +x decode-der-mzscheme
;; % ./decode-der-mzscheme
;; Released under the terms of the GNU General Public Licence
;;
;; $Revision$
;;
;; $Log$
;; Revision 1.14 2009/01/08 16:05:47 norman
;; Adjust URLs
;;
;; Revision 1.13 2008/12/11 21:02:34 norman
;; Preen comments
;;
;; Revision 1.12 2008/12/11 12:55:24 norman
;; @CONFIG@ stuff adjusted so that the mzscheme case produces a module file
;; SISC support fixed
;;
;; Revision 1.11 2008/12/10 17:04:01 norman
;; decode-der.scm can now parse a broader range of X.509 certificates, and this is exercised
;; in decode-der-mzscheme.in, which formats them in a variety of ways.
;;
;; Revision 1.10 2008/12/02 22:57:11 norman
;; Preen comments
;;
;; Revision 1.9 2008/12/02 22:50:00 norman
;; Remove der:last-error, der:decode-include-tag! and der:lookup-oids!,
;; replacing them with a more functional otions argument to der:decode
;;
;; Revision 1.8 2008/12/02 21:07:32 norman
;; Substantial reworking, to handle features found in other certificates
;;
;; Revision 1.7 2008/11/25 22:28:55 norman
;; Now copes with the indefinite-length encoding
;; This required substantial reimplementation, as it turned out,
;; but the result is a lot neater
;;
;; Revision 1.6 2008/07/02 22:05:11 norman
;; Adjustments to make webpage format correctly
;;
;; Revision 1.5 2008/07/02 21:51:27 norman
;; Add a main function for mzscheme
;; Change the behaviour when reading context sequences
;;
;; Revision 1.4 2006/09/05 07:41:01 norman
;; Tweaks to make configuration more mechanical
;;
;; Revision 1.3 2006/08/31 14:00:42 norman
;; DER:DECODE now returns #f on malformed DER values, rather than error
;; Added DER:LAST-ERROR to return error message in that case
;;
;; Revision 1.2 2006/08/12 22:09:58 norman
;; Tidied up for release:
;; Public functions given a der: prefix
;; All tests moved to the end
;; Added notes about configuration for particular systems, flagged
;; with string @CONFIG@
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Configuration for different Scheme implementations.
;; Uncomment as required.
;; Import SRFIs
;; mzscheme:
;@CONFIG mzscheme@#lang scheme
;@CONFIG mzscheme@(provide der:decode der:lookup-oid) ; declare for PLT 4
;@CONFIG mzscheme@(require (lib "8.ss" "srfi")) ; receive multiple values
;@CONFIG mzscheme@(require (lib "19.ss" "srfi")) ; date and time
;@CONFIG mzscheme@(require (lib "60.ss" "srfi")) ; bitwise arithmetic
;; sisc:
;@CONFIG sisc@(require-library 'sisc/libs/srfi/srfi-8) ; receive multiple values
;@CONFIG sisc@(require-library 'sisc/libs/srfi/srfi-19) ; date and time
;@CONFIG sisc@(require-library 'sisc/libs/srfi/srfi-60) ; bitwise arithmetic
;@CONFIG sisc@(module decode-der (der:decode der:lookup-oid)
;@CONFIG sisc@(import srfi-8)
;@CONFIG sisc@(import srfi-19)
;@CONFIG sisc@(import srfi-60)
;; scsh:
;; Give '-o srfi-8 -o srfi-60' on command line, or define a module with
;; (define-structure decode-der (export der:decode) (open srfi-8 srfi-19 srfi-60) ... )
;; ...except that srfi-60 isn't implemented for scsh.
;; SFORMAT string ... -> string
;; Format a string
;@CONFIG mzscheme@(define (sformat template . args)
;@CONFIG mzscheme@ (apply format (cons template args)))
;@CONFIG scsh@(define (sformat template . args)
;@CONFIG scsh@ (apply format (cons #f (cons template args))))
;@CONFIG sisc@(define (sformat template . args)
;@CONFIG sisc@ (apply format (cons #f (cons template args))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; The implementation
;; DER:DECODE : list -> decoded-value
;; Given a stream of octets as a list, return the first DER-decoded
;; value as an appropriate Scheme type.
(define (der:decode l . options)
(define (make-options defaults) ;return an options procedure, given an alist of defaults
(lambda (opt . val) ; with one arg, return value; with two args set value
(if (null? val)
(cond ((assq opt defaults) => cdr)
(else #f))
(make-options (cons (cons opt (car val)) defaults)))))
(call/cc
(lambda (escape)
(let* ((include-tags (cond ((assq 'include-tags options) => cadr)
(else #f)))
(translate-oids (cond ((assq 'translate-oids options) => cadr)
(else #f)))
(save-error (cond ((assq 'save-error options) => cadr)
(else (lambda (x) x))))
(malformed (cond ((assq 'malformed options) => cadr)
(else (lambda (fmt . args)
(save-error (apply sformat (cons fmt args)))
(escape #f))))))
(der:decode* l
(make-options `((include-tags . ,include-tags)
(translate-oids . ,translate-oids)
(save-error . ,save-error)
;(debug . ,display)
(debug . ,(lambda (x) #f))
(malformed . ,malformed))))))))
;; DER:DECODE* : list procedure -> object
;; Worker procedure for DER:DECODE
(define (der:decode* l options)
(receive (object rest)
(decode-one-object l options)
(cond ((null? rest) ;normal case
object)
((not object) ;error
((options 'malformed) "unexpected error: object=#f"))
(else ;more than one object in the stream
((options 'malformed) "DER encoded type has trailing content: ~s" rest)))))
;; PEEL-OFF-OCTETS : list procedure -> list list
;; given a list (length value ...) or (length length1... value...),
;; return two values, consisting of the list represented
;; by the appropriate number of octets from the beginning of L, and
;; the list coming after it.
;;
;; If the leading octets represent an indefinite-length object, then
;; return (values #f L).
;;
;; If the list is shorter than the length suggests, call the
;; MALFORMED procedure, with a string explanation
(define (peel-off-octets l options)
(let ((malformed (options 'malformed))
(debug (options 'debug)))
;; SPLIT-LIST idx list -> list list
;; splits the input LIST at the index IDX, returning two lists
;; If the index is negative or longer than the list, return (#f #f)
(define (split-list idx l)
(cond ((or (< idx 0) (> idx (length l)))
(malformed "Bad call to split-list: idx=~a, l=~s" idx l))
((= (length l) idx) ; common simple case
(values l '()))
(else
(let loop ((head '())
(tail l)
(count idx))
(if (<= count 0)
(values (reverse head) tail)
(loop (cons (car tail) head)
(cdr tail)
(- count 1)))))))
(debug (format "peel-off-octets:~s~%" l))
(cond ((null? l)
(malformed "peel-off-octets: input list is null!"))
((= (car l) #x80) ;indefinite-length
(values #f l))
((logtest (car l) #b10000000) ;definite-length multi-octet
(let loop ((lenlen (logand (car l) #b01111111))
(ll (cdr l))
(len 0))
(cond ((= lenlen 0)
(split-list len ll))
((null? ll)
(malformed "Short DER-encoded list: ~s" l))
(else
(loop (- lenlen 1) (cdr ll) (+ (arithmetic-shift len 8) (car ll)))))))
(else ; normal case
(split-list (car l) (cdr l))))))
;; DECODE-ONE-OBJECT : list procedure -> object list
;; Given a list, return multiple values: the next DER object in the list
;; (though we can also some simpler BER encodings), and any following content.
;;
;; If the first object is in the universal class, we return the object converted to
;; a suitable Scheme type. Otherwise, we return a list whose car is (foo . type),
;; where 'foo' is one of 'application, 'context or 'private, and 'type' is the type code
;; from the encoded stream, and whose cdr is the decoded contents, or the list contents
;; if it does not decode successfully.
;;
;; On errors, call the MALFORMED procedure with a string explanation.
(define (decode-one-object der-list options)
(let ((malformed (options 'malformed))
(debug (options 'debug)))
(define (get-object-and-tail class type l)
(receive (head tail)
(peel-off-octets l options)
(debug (format "get-object-and-tail: ~a/~a/~s => ~s ~s~%" class type l head tail))
(cond ((not head)
;; it's an indefinite-length object
(if (null? tail)
(malformed "get-object-and-tail: TAIL is null -- I didn't expect that")
(let loop ((octets (cdr tail))
(res '()))
(receive (object rest)
(decode-one-object octets options)
(cond ((not object)
(values res rest))
(else
(loop rest (append res (list object)))))))))
(head
(let ((maybe-decode-head
(lambda (head)
;; attempt to decode the HEAD, but if that's unsuccessful,
;; simply return the HEAD list
(or (call/cc
(lambda (escape)
(der:decode* head
(options 'malformed
(lambda (fmt . args)
((options 'save-error) (apply sformat (cons fmt args)))
(escape #f))))))
head))))
(values (case class
((0) (decode type head options))
((1) `((application . ,type) . ,(maybe-decode-head head)))
((2) `((context . ,type) . ,(maybe-decode-head head)))
((3) `((private . ,type) . ,(maybe-decode-head head))))
tail)))
(else
(malformed "couldn't decode object: der-list=~s" der-list)))))
(debug (format "decode-one-object: ~s~%" der-list))
(let ((class (arithmetic-shift (logand (car der-list) #b11000000) -6))
(type1 (logand (car der-list) #b00011111)))
(if (= type1 31)
(let loop ((t 0) ; high-tag-number form: tag number in following octets
(l (cdr der-list)))
(if (logtest (car l) #b10000000)
(loop (+ (* t 128) (logand (car l) #b01111111))
(cdr l))
(get-object-and-tail class (+ (* t 128) (car l)) (cdr l))))
(get-object-and-tail class type1 (cdr der-list))))))
;; DECODE : integer list procedure -> decoded-value
;; Given a type and the content as a list of octets, return the coded
;; object as a suitable Scheme type.
;;
;; We should get only numeric types here. That is, we don't expect to handle
;; non-universal types.
;;
;; If we do not recognise the type, call the MALFORMED procedure
(define (decode type l options)
(let ((malformed (options 'malformed))
(tag (if (options 'include-tags)
(lambda (tag-symbol value)
(cons tag-symbol value))
(lambda (tag-symbol value)
value)))
(lookup-oids? (options 'translate-oids)))
;; DECODE-BOOLEAN : list -> boolean
(define (decode-boolean l)
(tag 'boolean (if (= (car l) 0) 'false 'true)))
;; DECODE-OCTET-STRING : list -> list
;; easy!
(define (decode-octet-string l)
(tag 'octet-string l))
;; DECODE-GENERIC-STRING : list -> string
;; decode ASCII string -- used by string types below
(define (decode-generic-string l)
(list->string (map integer->char l)))
;; DECODE-IA5-STRING : list -> string
(define (decode-ia5-string l)
(tag 'ia5-string (decode-generic-string l)))
;; DECODE-PRINTABLE-STRING : list -> string
(define (decode-printable-string l)
(tag 'printable-string (decode-generic-string l)))
;; DECODE-T61-STRING : list -> string
;; Will this do as an implementation?
;; (it's not clear how to test this, as DrScheme doesn't seem to
;; allow entering non-ASCII characters
(define (decode-t61-string l)
(tag 't61-string (decode-generic-string l)))
;; DECODE-UTC-TIME : list -> SRFI-19-date
(define (decode-utc-time l)
(tag 'utc-time (string->date (decode-generic-string l) "~y~m~d~H~M~S~z")))
;; DECODE-GENERALIZED-TIME : list -> SRFI-19-date
(define (decode-generalized-time l)
(let ((s (decode-generic-string l)))
(if (char=? (string-ref s 14) #\.)
(tag 'generalized-time (string->date s "~Y~m~d~H~M~S.~N~z"))
(tag 'generalized-time (string->date s "~Y~m~d~H~M~S~z")))))
;; DECODE-OBJECT-IDENTIFIER : list -> string
;; Decode oid to a dotted-decimal representation
(define (decode-object-identifier l)
(let ((o1 (car l)))
(let loop ((roid (list (remainder o1 40) (quotient o1 40)))
(current 0)
(octets (cdr l)))
(cond ((null? octets)
(tag 'object-identifier
(let ((oid (string->symbol
(apply string-append
(cdr (let inc-dots ((nos (map number->string (reverse roid))))
(if (null? nos)
'()
`("." ,(car nos) . ,(inc-dots (cdr nos))))))))))
(if lookup-oids?
(or (der:lookup-oid oid) oid)
oid))))
((logtest (car octets) #b10000000) ; not the last one
(loop roid
(+ (* current 128) (logand (car octets) #b01111111))
(cdr octets)))
(else
(loop (cons (+ (* current 128) (car octets)) roid)
0
(cdr octets)))))))
;; DECODE-BIT-STRING : list -> vector of bytes
(define (decode-bit-string l)
(tag 'bit-string
(list->vector
(let ((padding-bits (car l)))
(cond ((= padding-bits 0)
(cdr l))
((or (< padding-bits 0) (> padding-bits 8)) ;eh?
(malformed "more than 8 padding bits in bit-string? ~s" l))
(else
(let loop ((in-bytes (cdr l))
(last-right 0))
(cond ((null? in-bytes)
;; last-right digits are to be ignored here (they're the padding)
'())
(else
(cons (+ (arithmetic-shift last-right (- 8 padding-bits))
(bit-field (car in-bytes) padding-bits 8))
(loop (cdr in-bytes)
(bit-field (car in-bytes) 0 padding-bits))))))))))))
;; DECODE-SET : list -> list
(define (decode-set l)
(tag 'set (decode-collection l)))
;; DECODE-SEQUENCE : list -> list
(define (decode-sequence l)
(tag 'sequence (decode-collection l)))
;; DECODE-COLLECTION : list -> list
(define (decode-collection l)
(let loop ((objs l))
(if (null? objs)
'()
(receive (object rest)
(decode-one-object objs options)
;(display (format "decode-collection: object=~s rest=~s~%" object rest))
(cons object (loop rest))))))
;; DECODE-INTEGER : list -> number
(define (decode-integer l)
(let ((int1 (car l)))
(let loop ((res (if (>= int1 #x80) (- int1 256) int1))
(octets (cdr l)))
(if (null? octets)
(tag 'integer res)
(loop (+ (* res 256) (car octets)) (cdr octets))))))
;; finally, the actual DECODE procedure body
(cond ((number? type)
(case type
((0)
;; non-type (should only appear during parsing of constructed
;; indefinite-length method
#f)
((1) (decode-boolean l))
((2) (decode-integer l))
((3) (decode-bit-string l))
((4) (decode-octet-string l))
((5) (tag 'null #f)) ; null type
((6) (decode-object-identifier l))
((16) (decode-sequence l))
((17) (decode-set l))
((19) (decode-printable-string l))
((20) (decode-t61-string l))
((22) (decode-ia5-string l))
((23) (decode-utc-time l))
((24) (decode-generalized-time l))
(else
(malformed "Unrecognised DER type ~a in ~s" type l))))
(else
(malformed "Unrecognised type ~s in ~s" type l)))))
;; more information is available at http://www.oid-info.com/get/
(define der:lookup-oid
(let ((oids '((1.2.840.113549.1.1.1
"{iso(1) member-body(2) us(840) rsadsi(113549) pkcs(1) pkcs-1(1) rsaEncryption(1)}")
(1.2.840.113549.1.1.4
"{iso(1) member-body(2) us(840) rsadsi(113549) pkcs(1) pkcs-1(1) md5WithRSAEncryption(4)}")
(1.2.840.113549.1.1.5
"{iso(1) member-body(2) us(840) rsadsi(113549) pkcs(1) pkcs-1(1) sha1-with-rsa-signature(5)}")
(1.2.840.113549.1.7.1
"{iso(1) member-body(2) us(840) rsadsi(113549) pkcs(1) pkcs-7(7) data(1)}")
(1.2.840.113549.1.7.2
"{iso(1) member-body(2) us(840) rsadsi(113549) pkcs(1) pkcs-7(7) signedData(2)}")
(1.2.840.113549.1.9.1
"{iso(1) member-body(2) us(840) rsadsi(113549) pkcs(1) pkcs-9(9) emailAddress(1)}")
(1.3.14.3.2.26
"{iso(1) identified-organization(3) oiw(14) secsig(3) algorithms(2) hashAlgorithmIdentifier(26)}")
(2.5.4.1
"{joint-iso-itu-t(2) ds(5) attributeType(4) aliasedEntryName(1)}")
(2.5.4.2
"{joint-iso-itu-t(2) ds(5) attributeType(4) knowledgeInformation(2)}")
(2.5.4.3
"{joint-iso-itu-t(2) ds(5) attributeType(4) commonName(3)}"
"CN")
(2.5.4.4
"{joint-iso-itu-t(2) ds(5) attributeType(4) surname(4)}")
(2.5.4.5
"{joint-iso-itu-t(2) ds(5) attributeType(4) serialNumber(5)}")
(2.5.4.6
"{joint-iso-itu-t(2) ds(5) attributeType(4) countryName(6)}"
"C")
(2.5.4.7
"{joint-iso-itu-t(2) ds(5) attributeType(4) localityName(7)}"
"L")
(2.5.4.8
"{joint-iso-itu-t(2) ds(5) attributeType(4) stateOrProvinceName(8)}"
"ST")
(2.5.4.9
"{joint-iso-itu-t(2) ds(5) attributeType(4) streetAddress(9)}"
"STREET")
(2.5.4.10
"{joint-iso-itu-t(2) ds(5) attributeType(4) organizationName(10)}"
"O")
(2.5.4.11
"{joint-iso-itu-t(2) ds(5) attributeType(4) organizationUnitName(11)}"
"OU")
(2.5.4.12
"{joint-iso-itu-t(2) ds(5) attributeType(4) title(12)}")
(2.5.4.13
"{joint-iso-itu-t(2) ds(5) attributeType(4) description(13)}")
(2.5.4.41
"{joint-iso-itu-t(2) ds(5) attributeType(4) name(41)}")
(2.5.4.42
"{joint-iso-itu-t(2) ds(5) attributeType(4) givenName(42)}")
(2.5.4.49
"{joint-iso-itu-t(2) ds(5) attributeType(4) distinguishedName(49)}"
"DN")
(2.5.29.14
"{joint-iso-itu-t(2) ds(5) ce(29) subjectKeyIdentifier(14)}")
(2.5.29.15
"{joint-iso-itu-t(2) ds(5) ce(29) keyUsage(15)}")
(2.5.29.17
"{joint-iso-itu-t(2) ds(5) ce(29) subjectAltName(17)}")
(2.5.29.18
"{joint-iso-itu-t(2) ds(5) ce(29) issuerAltName(18)}")
(2.5.29.19
"{joint-iso-itu-t(2) ds(5) ce(29) basicConstraints(19)}")
(2.5.29.31
"{joint-iso-itu-t(2) ds(5) ce(29) cRLDistributionPoints(31)}")
(2.5.29.32
"{joint-iso-itu-t(2) ds(5) ce(29) certificatePolicies(32)}")
(2.5.29.35
"{joint-iso-itu-t(2) ds(5) ce(29) authorityKeyIdentifier(35)}")
(2.16.840.1.113730.1.1
"{joint-iso-itu-t(2) country(16) us(840) organization(1) netscape(113730) 1 cert-type(1)}")
(2.16.840.1.113730.1.3
"{joint-iso-itu-t(2) country(16) us(840) organization(1) netscape(113730) 1 revocation-url(3)}")
(2.16.840.1.113730.1.4
"{joint-iso-itu-t(2) country(16) us(840) organization(1) netscape(113730) 1 ca-revocation-url(4)}")
(2.16.840.1.113730.1.13
"{joint-iso-itu-t(2) country(16) us(840) organization(1) netscape(113730) 1 comment(13)}")
)))
(lambda (oid . get-key)
(cond ((assq oid oids)
=> (lambda (oid-info)
(cond ((or (null? get-key) (not (car get-key)))
(cadr oid-info))
((>= (length oid-info) 3)
(caddr oid-info))
(else #f))))
(else
#f)))))
;@CONFIG sisc@)
;@CONFIG tests follow@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Support for regression tests.
;; Uncomment where indicated to suppress regression tests, and speed loading.
(define nfails 0)
(define-syntax expect
(syntax-rules ()
;;;((_ ...) #f) ; @CONFIG@: comment this line out to enable regression tests
((_) ; no test -- report on accumulated failures, or report success
(display (if (= nfails 0)
(sformat "All tests passed!~%")
(sformat "Failures: ~a~%" nfails))))
((_ expected form . forms)
(let ((test ((lambda () form . forms))))
(if (equal? expected test)
test
(begin (display (sformat "Test ~a~% produced ~s~% expected ~s~%"
(quote form . forms) test expected))
(set! nfails (+ nfails 1))
#f))))))
(define-syntax expect-values
(syntax-rules ()
;;;((_ ...) #f) ; @CONFIG@: comment this line out to enable regression tests
((_ (values ...) body ...)
(let ((testvals (call-with-values (lambda () body ...) (lambda v v))))
(if (equal? testvals '(values ...))
#t
(begin (display (sformat "Test (multivalues) ~a~% produced ~s~% expected ~s~%"
(quote body ...) testvals '(values ...)))
(set! nfails (+ nfails 1))
#f))))))
(define error-message-handler
(let ((msg #f))
(lambda args
(if (null? args)
msg
(set! msg (apply format args))))))
;; tests for SPLIT-LIST and DECODE-ONE-OBJECT removed, since they're
;; complicated to test because of the (private to der:decode) option argument,
;; and in any case they're not part of the interface.
;; tests for DER:DECODE
;; (or rather, those cases which are handled directly by it, rather than
;; being handed off)
(expect #f (der:decode '(5 0))) ; NULL
;; I'm not sure if the following case is desirable
;(expect '(1 2 3) (der:decode '(131 3 1 2 3)))
;; tests for DECODE-BOOLEAN
(expect 'true (der:decode '(1 1 1)))
(expect 'true (der:decode '(1 1 255)))
(expect 'false (der:decode '(1 1 0)))
;; tests for DECODE-OCTET-STRING
(expect '() (der:decode '(4 0)))
(expect '(48 0) (der:decode '(4 2 48 0)))
;; tests for DECODE-IA5-STRING
(expect "UK e-Science User Certificate"
(der:decode '(22 29 85 75 32 101 45
83 99 105 101 110 99 101 32 85
115 101 114 32 67 101 114 116
105 102 105 99 97 116 101)))
(expect "" (der:decode '(22 0)))
;; tests for DECODE-PRINTABLE-STRING
(expect "Test User 1"
(der:decode '(#x13 #x0b #x54 #x65 #x73 #x74 #x20
#x55 #x73 #x65 #x72 #x20 #x31)))
(expect #f
(der:decode '(#x13 #x0b #x54 #x65 #x73 #x74 #x20))) ;short list
(expect #f
(der:decode '(#x13 #x0b #x54 #x65 #x73 #x74 #x20
#x55 #x73 #x65 #x72 #x20 #x31 #xff))) ;long list
;; tests for DECODE-UTC-TIME
(expect (make-date 0 40 45 23 06 05 1991 0);"910506234540Z"
(der:decode '(#x17 #x0d #x39 #x31 #x30 #x35 #x30 #x36
#x32 #x33 #x34 #x35 #x34 #x30 #x5a)))
;; tests for DECODE-GENERALIZED-TIME
(expect (make-date 0 23 32 18 5 12 2008 0) ; "20081205183223Z"
(der:decode '(#x18 #x0f #x32 #x30 #x30 #x38 #x31 #x32
#x30 #x35 #x31 #x38 #x33 #x32 #x32 #x33 #x5a)))
(expect (make-date 500000000 23 32 18 5 12 2008 0) ; "20081205183223.5Z"
(der:decode '(#x18 #x11 #x32 #x30 #x30 #x38 #x31 #x32
#x30 #x35 #x31 #x38 #x33 #x32 #x32 #x33
#x2e #x35 #x5a)))
;; tests for DECODE-OBJECT-IDENTIFIER
(expect '1.2.840.113549 (der:decode '(6 6 42 134 72 134 247 13)))
(expect '1.2.840.113549.1.7.2 (der:decode '(6 9 42 134 72 134 247 13 1 7 2)))
(expect "{iso(1) member-body(2) us(840) rsadsi(113549) pkcs(1) pkcs-7(7) signedData(2)}"
(der:decode '(6 9 42 134 72 134 247 13 1 7 2) '(translate-oids #t)))
;; tests for DECODE-BIT-STRING
;; From Kaliski: bit string is 01 1011 1001 0111 0111
(expect '#(#x01 #xb9 #x77); not '#(#x6e #x5d #xc0)
(der:decode '(3 4 6 #x6e #x5d #xc0)))
(expect '#(#x01 #xb9 #x77)
(der:decode '(3 4 6 #x6e #x5d #xff))) ;non-zero padding bits (BER not DER)
(expect '#(#x00 #x00 #x00 #x00)
(der:decode '(3 5 0 #x00 #x00 #x00 #x00)))
;; tests for DECODE-COLLECTION (ie, DECODE-SEQUENCE and DECODE-SET)
(expect '() (der:decode '(48 0)))
(expect '((1.3.6.1.4.1.11439.1.1.1.1.6))
(der:decode '(48 16 48 14 6 12 43 6 1 4 1 217 47 1 1 1 1 6)))
;; I can't decide what (context . 1) tags should decode to -- is the following correct?
;; (expect '(((context . 1) ;; I don't think this is a legit sequence -- where did I get it from?
;; 99 97 45 111 112 101 114 97 116 111 114 64 103 114 105 100
;; 45 115 117 112 112 111 114 116 46 97 99 46 117 107))
;; (der:decode '(48 32
;; 129 30 ;(context . 1)
;; 99 97 45 111 112 101 114 97 116 111
;; 114 64 103 114 105 100 45 115 117 112
;; 112 111 114 116 46 97 99 46 117 107)))
(expect '("ca-operator@grid-support.ac.uk")
(der:decode '(48 32
19 30 ;printable-string
99 97 45 111 112 101 114 97 116 111
114 64 103 114 105 100 45 115 117 112
112 111 114 116 46 97 99 46 117 107)))
(expect '(((2.5.4.6 "US"))
((2.5.4.10 "Example Organization"))
((2.5.4.3 "Test User 1")))
(der:decode '(#x30 #x42
#x31 #x0b
#x30 #x09
#x06 #x03 #x55 #x04 #x06
#x13 #x02 #x55 #x53
#x31 #x1d
#x30 #x1b
#x06 #x03 #x55 #x04 #x0a
#x13 #x14
#x45 #x78 #x61 #x6d #x70 #x6c #x65
#x20 #x4f #x72 #x67 #x61 #x6e #x69
#x7a #x61 #x74 #x69 #x6f #x6e
#x31 #x14
#x30 #x12
#x06 #x03 #x55 #x04 #x03
#x13 #x0b
#x54 #x65 #x73 #x74 #x20 #x55 #x73
#x65 #x72 #x20 #x31)))
;; Tests of constructed-indefinite-length method
(expect '() ;sequence of nothing
(der:decode '(#x30 #x80 #x00 #x00)))
(expect '(1.2.840.113549.1.7.2) ;sequence of OID
(der:decode '(#x30 #x80 #x06 #x09 #x2a #x86 #x48 #x86 #xf7 #x0d #x01 #x07 #x02 #x00 #x00)))
;; an indefinite-length sequence which includes a bit-string which includes 00 00
(expect '(#(#x00 #x00 #x00 #x00))
(der:decode '(#x30 #x80 #x03 #x05 #x00 #x00 #x00 #x00 #x00 #x00 #x00)))
(expect '(((context . 0)
102 97 221 122 13 230 95 219 138 133 2 182 49 53 173 216 172 93 135 18)
((context . 1)
(context . 4)
((2.5.4.6 "UK"))
((2.5.4.10 "eScienceRoot"))
((2.5.4.11 "Authority"))
((2.5.4.3 "UK e-Science Root")))
((context . 2) 1))
(der:decode '(48 115 128 20 102 97 221 122 13 230 95 219 138 133 2 182 49 53 173 216 172 93 135 18 161 88 164 86 48 84 49 11 48 9 6 3 85 4 6 19 2 85 75 49 21 48 19 6 3 85 4 10 19 12 101 83 99 105 101 110 99 101 82 111 111 116 49 18 48 16 6 3 85 4 11 19 9 65 117 116 104 111 114 105 116 121 49 26 48 24 6 3 85 4 3 19 17 85 75 32 101 45 83 99 105 101 110 99 101 32 82 111 111 116 130 1 1)))
;; tests for DECODE-INTEGER
(expect 0 (der:decode '(2 1 0)))
(expect 127 (der:decode '(2 1 #x7f)))
(expect 128 (der:decode '(2 2 0 #x80)))
(expect 256 (der:decode '(2 2 1 0)))
(expect -128 (der:decode '(2 1 #x80)))
(expect -129 (der:decode '(2 2 #xff #x7f)))
;; tests with tagging true
;; These are repeats of some of the tests above, but with the include-tags option present
(expect '(sequence (set (sequence
(object-identifier . 2.5.4.6)
(printable-string . "US")))
(set (sequence
(object-identifier . 2.5.4.10)
(printable-string . "Example Organization")))
(set (sequence
(object-identifier . 2.5.4.3)
(printable-string . "Test User 1"))))
(der:decode '(#x30 #x42
#x31 #x0b
#x30 #x09
#x06 #x03 #x55 #x04 #x06
#x13 #x02 #x55 #x53
#x31 #x1d
#x30 #x1b
#x06 #x03 #x55 #x04 #x0a
#x13 #x14
#x45 #x78 #x61 #x6d #x70 #x6c #x65
#x20 #x4f #x72 #x67 #x61 #x6e #x69
#x7a #x61 #x74 #x69 #x6f #x6e
#x31 #x14
#x30 #x12
#x06 #x03 #x55 #x04 #x03
#x13 #x0b
#x54 #x65 #x73 #x74 #x20 #x55 #x73
#x65 #x72 #x20 #x31)
'(include-tags #t)))
(expect '(ia5-string . "UK")
(der:decode '(22 2 85 75)
'(include-tags #t)))
(expect (cons 'utc-time (make-date 0 40 45 23 06 05 1991 0));'(utc-time . "910506234540Z")
(der:decode '(#x17 #x0d #x39 #x31 #x30 #x35 #x30 #x36
#x32 #x33 #x34 #x35 #x34 #x30 #x5a)
'(include-tags #t)))
(expect '(integer . 127)
(der:decode '(2 1 #x7f)
'(include-tags #t)))
(expect '(null . #f)
(der:decode '(5 0)
'(include-tags #t)))
;(expect '((context . 3) 1 2 3) (der:decode '(131 3 1 2 3)
; '(include-tags #t)))
(expect `(sequence
(sequence
((context . 0) integer . 2)
(integer . 153149265108183633732783631236669912100)
(sequence (object-identifier . 1.2.840.113549.1.1.5)
(null . #f))
(sequence (set (sequence (object-identifier . 2.5.4.6)
(printable-string . "ZA")))
(set (sequence (object-identifier . 2.5.4.10)
(printable-string . "Thawte Consulting (Pty) Ltd.")))
(set (sequence (object-identifier . 2.5.4.3)
(printable-string . "Thawte Personal Freemail Issuing CA"))))
(sequence (utc-time . ,(make-date 0 51 37 18 2 7 2008 0))
(utc-time . ,(make-date 0 51 37 18 2 7 2009 0)))
(sequence (set (sequence (object-identifier . 2.5.4.4)
(printable-string . "Gray")))
(set (sequence (object-identifier . 2.5.4.42)
(printable-string . "Norman")))
(set (sequence (object-identifier . 2.5.4.3)
(printable-string . "Norman Gray")))
(set (sequence (object-identifier . 1.2.840.113549.1.9.1)
(ia5-string . "norman@astro.gla.ac.uk"))))
(sequence (sequence (object-identifier . 1.2.840.113549.1.1.1)
(null . #f))
(bit-string . #(48 130 1 10 2 130 1 1 0 214 238 66 1 34 100 171 225 127 85 104
211 166 220 109 76 230 57 30 111 59 133 223 40 185 221 241 169 132 125 48
234 248 148 11 160 179 242 129 36 41 100 174 237 115 212 33 188 133 58 19
136 97 247 130 170 237 220 175 164 170 136 4 186 78 103 95 81 2 16 59
29 197 205 239 139 137 199 60 40 24 200 254 104 124 55 13 85 35 136 110
181 176 219 215 178 65 210 127 222 87 37 151 148 91 182 104 247 215 255 7
94 58 123 93 140 183 209 19 145 211 196 110 77 134 219 137 188 76 190 31
134 16 104 107 160 64 167 76 31 249 207 150 129 232 141 59 114 156 222 131
24 156 124 214 247 74 72 180 175 221 190 88 3 191 29 67 170 105 228 15
73 94 136 63 8 92 248 245 194 63 140 58 70 110 205 90 0 208 228 221
99 116 233 51 202 66 17 196 242 110 174 103 157 20 114 153 201 244 18 155
94 12 126 173 33 75 190 229 185 244 136 115 132 119 242 20 51 97 229 126
107 46 184 36 161 46 162 163 53 119 53 81 124 224 153 28 40 46 218 99
198 75 212 61 59 2 3 1 0 1)))
((context . 3)
sequence
(sequence (object-identifier . 2.5.29.17)
(octet-string 48 24 129 22 110 111 114 109 97 110 64 97 115 116 114 111 46 103 108 97 46 97 99 46 117 107))
(sequence (object-identifier . 2.5.29.19)
(boolean . true)
(octet-string 48 0))))
(sequence (object-identifier . 1.2.840.113549.1.1.5)
(null . #f))
(bit-string . #(173 137 32 153 37 47 129 165 212 195 83 16 237 34 182 134 149 58 115 219
58 227 133 127 69 38 189 45 231 20 155 34 157 226 188 139 102 222 101 19
130 7 32 62 153 151 50 117 219 166 18 224 57 119 6 240 182 242 181 94
9 18 148 229 79 183 171 221 129 170 206 119 42 38 131 183 145 78 79 93
25 184 75 198 88 10 165 72 149 154 180 236 193 143 71 11 56 105 167 18
232 114 125 173 169 110 231 186 76 172 53 122 167 249 146 10 146 170 104 106
157 42 125 223 72 237 12 16)))
(der:decode '(#x30 #x82 #x02 #xfb ;constructed sequence of 763 octets
#x30 #x82 #x02 #x64 ;constructed sequence of 612 octets
#xa0 #x03 #x02 #x01 #x02 ;constructed context-specific tag 0, with integer 2
#x02 #x10
#x73 #x37 #x79 #xbe #x83 #xc9 #x5d #xc9 #x25 #xaa #x08 #xd9 #x8b #x2c #x34 #x24
#x30 #x0d ;oid and null
#x06 #x09 #x2a #x86 #x48 #x86 #xf7 #x0d #x01 #x01 #x05 #x05 #x00
#x30 #x62 ;sequence of 98 octets
#x31 #x0b #x30 #x09 #x06 #x03 #x55 #x04 #x06 #x13 #x02 #x5a #x41 #x31 #x25 #x30
#x23 #x06 #x03 #x55 #x04 #x0a #x13 #x1c #x54 #x68 #x61 #x77 #x74 #x65 #x20 #x43
#x6f #x6e #x73 #x75 #x6c #x74 #x69 #x6e #x67 #x20 #x28 #x50 #x74 #x79 #x29 #x20
#x4c #x74 #x64 #x2e #x31 #x2c #x30 #x2a #x06 #x03 #x55 #x04 #x03 #x13 #x23 #x54
#x68 #x61 #x77 #x74 #x65 #x20 #x50 #x65 #x72 #x73 #x6f #x6e #x61 #x6c #x20 #x46
#x72 #x65 #x65 #x6d #x61 #x69 #x6c #x20 #x49 #x73 #x73 #x75 #x69 #x6e #x67 #x20
#x43 #x41
#x30 #x1e ;sequence of 30 octets
#x17 #x0d ;utctime, 13 octets
#x30 #x38 #x30 #x37 #x30 #x32 #x31 #x38 #x33 #x37 #x35 #x31 #x5a
#x17 #x0d ;utctime, 13 octets
#x30 #x39 #x30 #x37 #x30 #x32 #x31 #x38 #x33 #x37 #x35 #x31 #x5a
#x30 #x5d ;sequence, 93 octets
#x31 #x0d #x30 #x0b #x06 #x03 #x55 #x04 #x04 #x13 #x04 #x47 #x72 #x61 #x79 #x31
#x0f #x30 #x0d #x06 #x03 #x55 #x04 #x2a #x13 #x06 #x4e #x6f #x72 #x6d #x61 #x6e
#x31 #x14 #x30 #x12 #x06 #x03 #x55 #x04 #x03 #x13 #x0b #x4e #x6f #x72 #x6d #x61
#x6e #x20 #x47 #x72 #x61 #x79 #x31 #x25 #x30 #x23 #x06 #x09 #x2a #x86 #x48 #x86
#xf7 #x0d #x01 #x09 #x01 #x16 #x16 #x6e #x6f #x72 #x6d #x61 #x6e #x40 #x61 #x73
#x74 #x72 #x6f #x2e #x67 #x6c #x61 #x2e #x61 #x63 #x2e #x75 #x6b
#x30 #x82 #x01 #x22 ;sequence, 290 octets
#x30 #x0d #x06 #x09 #x2a #x86 #x48 #x86 #xf7 #x0d #x01 #x01 #x01 #x05 #x00 #x03
#x82 #x01 #x0f #x00 #x30 #x82 #x01 #x0a #x02 #x82 #x01 #x01 #x00 #xd6 #xee #x42
#x01 #x22 #x64 #xab #xe1 #x7f #x55 #x68 #xd3 #xa6 #xdc #x6d #x4c #xe6 #x39 #x1e
#x6f #x3b #x85 #xdf #x28 #xb9 #xdd #xf1 #xa9 #x84 #x7d #x30 #xea #xf8 #x94 #x0b
#xa0 #xb3 #xf2 #x81 #x24 #x29 #x64 #xae #xed #x73 #xd4 #x21 #xbc #x85 #x3a #x13
#x88 #x61 #xf7 #x82 #xaa #xed #xdc #xaf #xa4 #xaa #x88 #x04 #xba #x4e #x67 #x5f
#x51 #x02 #x10 #x3b #x1d #xc5 #xcd #xef #x8b #x89 #xc7 #x3c #x28 #x18 #xc8 #xfe
#x68 #x7c #x37 #x0d #x55 #x23 #x88 #x6e #xb5 #xb0 #xdb #xd7 #xb2 #x41 #xd2 #x7f
#xde #x57 #x25 #x97 #x94 #x5b #xb6 #x68 #xf7 #xd7 #xff #x07 #x5e #x3a #x7b #x5d
#x8c #xb7 #xd1 #x13 #x91 #xd3 #xc4 #x6e #x4d #x86 #xdb #x89 #xbc #x4c #xbe #x1f
#x86 #x10 #x68 #x6b #xa0 #x40 #xa7 #x4c #x1f #xf9 #xcf #x96 #x81 #xe8 #x8d #x3b
#x72 #x9c #xde #x83 #x18 #x9c #x7c #xd6 #xf7 #x4a #x48 #xb4 #xaf #xdd #xbe #x58
#x03 #xbf #x1d #x43 #xaa #x69 #xe4 #x0f #x49 #x5e #x88 #x3f #x08 #x5c #xf8 #xf5
#xc2 #x3f #x8c #x3a #x46 #x6e #xcd #x5a #x00 #xd0 #xe4 #xdd #x63 #x74 #xe9 #x33
#xca #x42 #x11 #xc4 #xf2 #x6e #xae #x67 #x9d #x14 #x72 #x99 #xc9 #xf4 #x12 #x9b
#x5e #x0c #x7e #xad #x21 #x4b #xbe #xe5 #xb9 #xf4 #x88 #x73 #x84 #x77 #xf2 #x14
#x33 #x61 #xe5 #x7e #x6b #x2e #xb8 #x24 #xa1 #x2e #xa2 #xa3 #x35 #x77 #x35 #x51
#x7c #xe0 #x99 #x1c #x28 #x2e #xda #x63 #xc6 #x4b #xd4 #x3d #x3b #x02 #x03 #x01
#x00 #x01
#xa3 #x33 ; context.3, length 51
#x30 #x31 #x30 #x21 #x06 #x03 #x55 #x1d #x11 #x04 #x1a #x30 #x18 #x81 #x16 #x6e
#x6f #x72 #x6d #x61 #x6e #x40 #x61 #x73 #x74 #x72 #x6f #x2e #x67 #x6c #x61 #x2e
#x61 #x63 #x2e #x75 #x6b #x30 #x0c #x06 #x03 #x55 #x1d #x13 #x01 #x01 #xff #x04
#x02 #x30 #x00
#x30 #x0d ;sequence, length 13
#x06 #x09 #x2a #x86 #x48 #x86 #xf7 #x0d #x01 #x01 #x05 #x05 #x00
#x03 #x81 #x81 ;bit string, length 129
#x00 #xad #x89 #x20 #x99 #x25 #x2f #x81 #xa5 #xd4 #xc3 #x53 #x10 #xed #x22 #xb6
#x86 #x95 #x3a #x73 #xdb #x3a #xe3 #x85 #x7f #x45 #x26 #xbd #x2d #xe7 #x14 #x9b
#x22 #x9d #xe2 #xbc #x8b #x66 #xde #x65 #x13 #x82 #x07 #x20 #x3e #x99 #x97 #x32
#x75 #xdb #xa6 #x12 #xe0 #x39 #x77 #x06 #xf0 #xb6 #xf2 #xb5 #x5e #x09 #x12 #x94
#xe5 #x4f #xb7 #xab #xdd #x81 #xaa #xce #x77 #x2a #x26 #x83 #xb7 #x91 #x4e #x4f
#x5d #x19 #xb8 #x4b #xc6 #x58 #x0a #xa5 #x48 #x95 #x9a #xb4 #xec #xc1 #x8f #x47
#x0b #x38 #x69 #xa7 #x12 #xe8 #x72 #x7d #xad #xa9 #x6e #xe7 #xba #x4c #xac #x35
#x7a #xa7 #xf9 #x92 #x0a #x92 #xaa #x68 #x6a #x9d #x2a #x7d #xdf #x48 #xed #x0c
#x10
)
'(include-tags #t)))
;; basic test of error handling
(let ((error-catcher
(let ((msg #f))
(lambda args
(if (null? args)
msg
(set! msg (car args)))))))
(expect #t
(begin (der:decode '(99 99 99) ;garbage DER
`(save-error ,error-catcher))
(string? (error-catcher)))))
;; Show test results
(expect)
;; History:
;; changeset: 62:a91636e8b13d
;; user: norman
;; date: Thu Jan 08 16:05:47 2009 +0000
;; summary: Adjust URLs
;;
;; changeset: 61:ebe32299c6c6
;; user: norman
;; date: Thu Dec 11 21:02:34 2008 +0000
;; summary: Preen comments
;;
;; changeset: 60:bbbf4c017f59
;; user: norman
;; date: Thu Dec 11 12:55:25 2008 +0000
;; summary: @CONFIG@ stuff adjusted so that the mzscheme case produces a module file
;;
;; changeset: 59:d604dd5e633b
;; user: norman
;; date: Wed Dec 10 17:04:01 2008 +0000
;; summary: decode-der.scm can now parse a broader range of X.509 certificates, and this is exercised
;;
;; changeset: 56:faa764382461
;; user: norman
;; date: Tue Dec 02 22:57:11 2008 +0000
;; summary: Preen comments
;;
;; changeset: 55:c69419131b7b
;; user: norman
;; date: Tue Dec 02 22:50:00 2008 +0000
;; summary: Remove der:last-error, der:decode-include-tag! and der:lookup-oids!,
;;
;; changeset: 54:5c8700a8704a
;; user: norman
;; date: Tue Dec 02 21:07:32 2008 +0000
;; summary: Substantial reworking, to handle features found in other certificates
;;
;; changeset: 53:4cf3fa665d62
;; user: norman
;; date: Tue Nov 25 22:28:55 2008 +0000
;; summary: Now copes with the indefinite-length encoding
;;
;; changeset: 51:5951b0720b9f
;; user: norman
;; date: Wed Jul 02 23:05:11 2008 +0100
;; summary: Adjustments to make webpage format correctly
;;
;; changeset: 50:56294e6d15b2
;; user: norman
;; date: Wed Jul 02 22:51:27 2008 +0100
;; summary: Add a main function for mzscheme
;;
;; changeset: 38:3eeb67bb352e
;; user: norman
;; date: Tue Sep 05 08:41:01 2006 +0100
;; summary: Tweaks to make configuration more mechanical
;;
;; changeset: 32:8ef94c57ea65
;; user: norman
;; date: Thu Aug 31 15:00:42 2006 +0100
;; summary: DER:DECODE now returns #f on malformed DER values, rather than error
;;
;; changeset: 29:74052d6cf10c
;; user: norman
;; date: Sat Aug 12 23:09:58 2006 +0100
;; summary: Tidied up for release:
;;
;; changeset: 20:7afd2a1dc9c3
;; user: norman
;; date: Mon Jul 24 12:44:42 2006 +0100
;; summary: Initial version
;;