Add more asn.1 types.

Julien LepillerSun Feb 02 21:13:28+0100 2020

9fb2a35

Add more asn.1 types.

http-signature/asn1.scm

2626 
            make-asn1-type
2727 
            asn1-type-name
2828 
            asn1-type-type
29+
            asn1-type-primitive?
30+
            asn1-type-constructed?
2931 
            asn1-type-parser
3032 
            asn1-type-producer
33+
            asn1-type-aggregator
3134 
3235 
            asn1:bool
3336 
            asn1:null
37+
            asn1:int-bv
38+
            asn1:bitstring
39+
            asn1:octetstring
40+
            asn1:object-identifier
3441 
            asn1:sequence
3542 
3643 
            encode-asn1
…
4148 
;; a DER encoded ASN.1 record, or to produce a DER-encoded ASN.1 record.
4249 
4350 
(define-record-type asn1-type
44-
  (make-asn1-type name type parser producer)
51+
  (make-asn1-type name type primitive? constructed? parser producer aggregator)
4552 
  asn1-type?
4653 
  (name asn1-type-name)
4754 
  (type asn1-type-type)
55+
  (primitive? asn1-type-primitive?)
56+
  (constructed? asn1-type-constructed?)
4857 
  (parser asn1-type-parser)
49-
  (producer asn1-type-producer))
58+
  (producer asn1-type-producer)
59+
  (aggregator asn1-type-aggregator))
5060 
5161 
(define asn1:bool
5262 
  (make-asn1-type
53-
    "bool" 1
63+
    "bool" 1 #t #f
5464 
    (lambda (bv pos len)
5565 
      (unless (equal? len 1)
5666 
        (throw 'invalid-bool-value))
…
5969 
    (lambda (value)
6070 
      (let ((bv (make-bytevector 1)))
6171 
        (bytevector-u8-set! bv 0 (if value #xff #x00))
62-
        bv))))
72+
        bv))
73+
    (lambda _ (throw 'primitive-type))))
6374 
6475 
(define asn1:null
6576 
  (make-asn1-type
66-
    "null" 5
77+
    "null" 5 #t #f
6778 
    (lambda (bv pos len)
6879 
      (unless (equal? len 0)
6980 
        (throw 'invalid-null-value))
7081 
      #nil)
7182 
    (lambda (value)
72-
      (make-bytevector 0))))
83+
      (make-bytevector 0))
84+
    (lambda _ (throw 'primitive-type))))
85+
86+
;(define asn1:int-int
87+
;  (make-asn1-type
88+
;    "int" 2
89+
;    (lambda (bv pos len)
90+
;      (let ((ans (make-bytevector len)))
91+
;        (bytevector-copy! bv pos ans 0 len)
92+
;        (let loop ((num 0) (off 0))
93+
;          (if (> off len)
94+
;            num
95+
;            (loop (+ (* num 256) (bytevector-u8-ref bv off))
96+
;                  (+ off 1))))))
97+
;    (lambda (value)
98+
;      ())))
99+
100+
(define asn1:int-bv
101+
  (make-asn1-type
102+
    "int" 2 #t #f
103+
    (lambda (bv pos len)
104+
      (let ((ans (make-bytevector len)))
105+
        (bytevector-copy! bv pos ans 0 len)
106+
        ans))
107+
    (lambda (value)
108+
      value)
109+
    (lambda _ (throw 'primitive-type))))
110+
111+
;(define asn1:enum asn1:int-int)
112+
113+
(define asn1:bitstring
114+
  (make-asn1-type
115+
    "bitstring" 3 #t #t
116+
    (lambda (bv pos len)
117+
      (let ((ans (make-bytevector len)))
118+
        (bytevector-copy! bv pos ans 0 len)
119+
        ans))
120+
    (lambda (value)
121+
      value)
122+
    (lambda (value)
123+
      (apply bv-append value))))
124+
125+
(define asn1:octetstring
126+
  (make-asn1-type
127+
    "octetstring" 4 #t #t
128+
    (lambda (bv pos len)
129+
      (let ((ans (make-bytevector len)))
130+
        (bytevector-copy! bv pos ans 0 len)
131+
        ans))
132+
    (lambda (value)
133+
      value)
134+
    (lambda (value)
135+
      (apply bv-append value))))
136+
137+
(define asn1:object-identifier
138+
  (make-asn1-type
139+
    "object-identifier" 6 #t #f
140+
    (lambda (bv pos len)
141+
      (when (= len 0)
142+
        (throw 'invalid-object-identifier))
143+
      (let loop ((len len) (pos pos) (value '()) (new? #t))
144+
        (if (<= len 0)
145+
            (if (= len 0)
146+
                (let* ((vals (reverse value))
147+
                       (first-identifier (car vals)))
148+
                  (append
149+
                    (cond
150+
                      ((< first-identifier 40) (list 0 (modulo first-identifier 40)))
151+
                      ((< first-identifier 80) (list 1 (modulo first-identifier 40)))
152+
                      (else (list 2 (- first-identifier 80))))
153+
                    (cdr vals)))
154+
                (throw 'value-too-long))
155+
            (let* ((val (bytevector-u8-ref bv pos))
156+
                   (cont? (> val #x80))
157+
                   (val (logand #x7f val)))
158+
              (if new?
159+
                (loop (- len 1) (+ pos 1)
160+
                      (cons val value)
161+
                      (not cont?))
162+
                (loop (- len 1) (+ pos 1)
163+
                      (cons (+ val (* (car value) 128)) (cdr value))
164+
                      (not cont?)))))))
165+
    (lambda (value)
166+
      (match value
167+
        ((x y rest ...)
168+
         (let ((first-byte (+ (* x 40) y)))
169+
           (apply bv-append
170+
             (map
171+
               (lambda (identifier)
172+
                 (define (id-len identifier)
173+
                   (if (< identifier 128)
174+
                       1
175+
                       (+ 1 (id-len (quotient identifier 128)))))
176+
                 (let ((bv (make-bytevector (id-len identifier))))
177+
                   (let loop ((pos (- (bytevector-length bv) 1)) (id identifier))
178+
                     (if (= pos (- (bytevector-length bv) 1))
179+
                       (begin
180+
                         (bytevector-u8-set! bv pos (modulo id 128))
181+
                         (loop (- pos 1) (quotient id 128)))
182+
                       (if (= pos -1)
183+
                           bv
184+
                           (begin
185+
                             (bytevector-u8-set! bv pos (+ #x80 (modulo id 128)))
186+
                             (loop (- pos 1) (quotient id 128))))))))
187+
               (cons first-byte rest)))))
188+
        (_ (throw 'invalid-identifier))))
189+
    (lambda _ (throw 'primitive-type))))
73190 
74191 
;; Note that a sequence depends on the types of its contents
75192 
(define* (asn1:sequence . types)
76193 
  (make-asn1-type
77-
    "sequence" #x30
194+
    "sequence" #x10 #f #t
78195 
    (lambda (bv pos len)
79196 
      (let loop ((result '()) (types types) (rest-len len) (pos pos))
80197 
        (match types
…
91208 
        (throw 'incompatible-type-and-value-sizes))
92209 
      (apply
93210 
        bv-append
94-
        (map encode-asn1 types value)))))
211+
        (map encode-asn1 types value)))
212+
    (lambda (value) value)))
95213 
96214 
97215 
;; Now these functions are related to parsing or producing DER-encoded values
…
118236 
          (- first-byte 127); one for the size byte too, so 127 not 128
119237 
          1)))
120238 
239+
  (define (constructed? type-byte)
240+
    (not (eq? (logand type-byte #x20) 0)))
241+
242+
  (define (decode-asn1-array bv pos type)
243+
    (let loop ((value '()) (pos pos))
244+
      (if (= (bytevector-u8-ref bv pos) 0)
245+
          (begin
246+
            (unless (= (bytevector-u8-ref bv (+ pos 1)) 0)
247+
              (throw 'invalid-EOC-length))
248+
            (cons ((asn1-type-aggregator type) (reverse value)) (+ pos 2)))
249+
          (let* ((res (decode-asn1-aux bv pos type))
250+
                 (val (car res))
251+
                 (pos (cdr res)))
252+
            (loop (cons val value) pos)))))
253+
121254 
  (let* ((type-byte (bytevector-u8-ref bv pos))
255+
         (constructed? (constructed? type-byte))
122256 
         (pos (+ pos 1))
257+
         (len-byte (bytevector-u8-ref bv pos))
123258 
         (len (decode-len bv pos))
124259 
         (pos (+ pos (lenlen bv pos))))
125-
    (unless (equal? type-byte (asn1-type-type type))
126-
      (throw 'invalid-type-byte))
127-
    (cons ((asn1-type-parser type) bv pos len) (+ pos len))))
260+
    (unless (equal? (- type-byte (if constructed? #x20 0)) (asn1-type-type type))
261+
      (throw 'invalid-type-byte type-byte type))
262+
    (when (and constructed? (not (asn1-type-constructed? type)))
263+
      (throw 'invalid-constructed-type))
264+
    (when (and (not constructed?) (not (asn1-type-primitive? type)))
265+
      (throw 'invalid-primitive-type))
266+
    (if (and constructed? (equal? len-byte #x80))
267+
      (decode-asn1-array bv pos type)
268+
      (cons ((asn1-type-parser type) bv pos len) (+ pos len)))))
128269 
129270 
(define (decode-asn1 bv type)
130271 
  "Decode the content of @var{bv}, a DER record of @var{type}"
…
135276 
  "Encode the @var{value} of @var{type} into a DER record represented by a
136277 
bytevector."
137278 
  (let* ((type-byte (asn1-type-type type))
279+
         (type-byte (if (not (asn1-type-primitive? type))
280+
                        (+ #x20 type-byte)
281+
                        type-byte))
138282 
         (value ((asn1-type-producer type) value))
139283 
         (len (encode-len (bytevector-length value)))
140284 
         (type-bv (make-bytevector 1)))
141285 
    (bytevector-u8-set! type-bv 0 type-byte)
142-
    (pk 'encode type-bv len value)
143286 
    (bv-append type-bv len value)))
144287 
145288 
(define (bv-append . bvs)