syndicate-lang
/
syndicate-ssh
forked from syndicate-lang/marketplace-ssh-2014
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

asn1-ber.rkt: No longer needed

This commit is contained in:
Tony Garnock-Jones 2021-06-17 15:59:01 +02:00
parent 995a81c7e6
commit 11c6ca49b5
2 changed files with 0 additions and 212 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

167
syndicate-ssh/asn1-ber.rkt
View File

@ -1,167 +0,0 @@
#lang racket/base
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
;;; A very small subset of ASN.1 BER (from ITU-T X.690), suitable for
;;; en- and decoding public-key data for the ssh-rsa and ssh-dss
;;; algorithms.
(require racket/match)
(require bitsyntax)
(provide t:long-ber-tag
t:ber-length-indicator
asn1-ber-decode-all
asn1-ber-decode
asn1-ber-encode)
(define-syntax t:long-ber-tag
(syntax-rules ()
((_ #t input ks kf) (read-long-tag input ks kf))
((_ #f v) (write-long-tag v))))
(define (read-long-tag input ks kf)
(let loop ((acc 0)
(input input))
(bit-string-case input
([ (= 1 :: bits 1)
(x :: bits 7)
(rest :: binary) ]
(loop (+ x (arithmetic-shift acc 7)) rest))
([ (= 0 :: bits 1)
(x :: bits 7)
(rest :: binary) ]
(when (not (zero? x)))
(ks (+ x (arithmetic-shift acc 7)) rest))
(else (kf)))))
(define (write-long-tag v)
(list->bytes
(reverse-and-set-high-bits
(let loop ((v v))
(if (< v 128)
(list v)
(cons (bitwise-and v 127)
(loop (arithmetic-shift v -7))))))))
(define (reverse-and-set-high-bits bs)
(let loop ((acc (list (car bs)))
(bs (cdr bs)))
(if (null? bs)
acc
(loop (cons (bitwise-ior 128 (car bs)) acc) (cdr bs)))))
(define-syntax t:ber-length-indicator
(syntax-rules ()
((_ #t input ks0 kf)
(let ((ks ks0)) ;; avoid code explosion
(bit-string-case input
([ (= 128 :: bits 8)
(rest :: binary) ]
(ks 'indefinite rest))
([ (= 0 :: bits 1)
(len :: bits 7)
(rest :: binary) ]
(ks len rest))
([ (= 1 :: bits 1)
(lenlen :: bits 7)
(len :: integer bytes lenlen)
(rest :: binary) ]
(when (not (= lenlen 127))) ;; restriction from section 8.1.3.5
(ks len rest))
(else (kf)))))
((_ #f len)
(cond
((eq? len 'indefinite)
(bytes 128))
((< len 128)
(bytes len))
(else
(let ((lenlen (quotient (+ 7 (integer-length len)) 8)))
(bit-string (1 :: bits 1)
(lenlen :: bits 7)
(len :: integer bytes lenlen))))))))
(define (asn1-ber-decode-all packet)
(let-values (((value rest) (asn1-ber-decode packet)))
(if (equal? rest #"")
value
(error 'asn1-ber-decode-all "Trailing bytes present in encoded ASN.1 BER term"))))
(define (asn1-ber-decode packet)
(asn1-ber-decode* packet (lambda (class tag value rest)
(values (list class tag value)
(bit-string->bytes rest)))))
(define (asn1-ber-decode* packet k)
(bit-string-case packet
;; Tag with number >= 31
([ (class :: bits 2)
(constructed :: bits 1)
(= 31 :: bits 5)
(tag :: (t:long-ber-tag))
(length :: (t:ber-length-indicator))
(rest :: binary) ]
(asn1-ber-decode-contents class constructed tag length rest k))
([ (class :: bits 2)
(constructed :: bits 1)
(tag :: bits 5)
(length :: (t:ber-length-indicator))
(rest :: binary) ]
(asn1-ber-decode-contents class constructed tag length rest k))))
(define (asn1-ber-decode-contents class constructed tag length rest k)
(cond
((= constructed 1)
(define indefinite? (eq? length 'indefinite))
(define block (if indefinite? rest (sub-bit-string rest 0 (* length 8))))
(asn1-ber-decode-seq block indefinite? (lambda (seq rest) (k class tag seq rest))))
((= constructed 0)
(bit-string-case rest
([ (block :: binary bytes length)
(rest :: binary) ]
(k class tag (bit-string->bytes block) rest))))))
(define (asn1-ber-decode-seq packet indefinite? k)
(let loop ((rest packet)
(k k))
(if (and (bit-string-empty? rest)
(not indefinite?))
(k '() rest)
(asn1-ber-decode* rest
(lambda (class tag value rest)
(if (and indefinite?
(= class 0)
(= tag 0)
(equal? value #""))
(k '() rest)
(loop rest
(lambda (seq rest)
(k (cons (list class tag value) seq) rest)))))))))
(define (asn1-ber-encode entry)
(bit-string->bytes (asn1-ber-encode* entry)))
(define (asn1-ber-encode* entry)
(match entry
(`(,class ,tag ,value)
(if (list? value)
(let* ((encoded-values (map asn1-ber-encode* value))
(content-octets (foldr bit-string-append #"" encoded-values))
(content-length (quotient (bit-string-length content-octets) 8)))
(bit-string (class :: bits 2)
(1 :: bits 1) ;; constructed
((asn1-ber-encode-tag tag) :: binary)
(content-length :: (t:ber-length-indicator))
(content-octets :: binary bytes content-length)))
(bit-string (class :: bits 2)
(0 :: bits 1) ;; not constructed
((asn1-ber-encode-tag tag) :: binary)
((bytes-length value) :: (t:ber-length-indicator))
(value :: binary))))))
(define (asn1-ber-encode-tag tag)
(if (>= tag 31)
(bit-string (31 :: bits 5) (tag :: (t:long-ber-tag)))
(bit-string (tag :: bits 5))))

45
syndicate-ssh/test/test-asn1-ber.rkt
View File

@ -1,45 +0,0 @@
#lang racket/base
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(module+ test
(require rackunit)
(require "../asn1-ber.rkt")
(require bitsyntax)
(define dsa-key
#"0\201\336\2@\v\336jE\275\310\266\313y\365\307\e\243\304p\b8l=\3419\227\262\340E\253\333\263%X<\0235\374\30b \367\244\306\253/\22\213b\27\333\203Q\376zS\1\fS\312[\2553\rj\252C-\2A\0\207\26gPqe\245\3632:\5\317\345w\373\v8\231g\3155\376\270\256\f\250c\271\253\2\276\32\365\246\f\265\243\220\36\0302\349\3wI\vZ$I\320\374f\235KX\37\361\235\333\335\236\326\301\2\25\0\215rI\353\212\275\360\222c\365\r\310Z~E\327\337\30\344e\2@.F\2726\24w\352\352%\213~O\2Y\352\246`\246\243\fi\3\v\262\311w\0\211\241.\35\20\377\207F\321\375\354\347\336z3*\241N\347CT\254W98\311'&\204E\277\220\241\343\23sG")
;; #"3081de02400bde6a45bdc8b6cb79f5c71ba3c47008386c3de13997b2e045abdbb325583c1335fc186220f7a4c6ab2f128b6217db8351fe7a53010c53ca5bad330d6aaa432d024100871667507165a5f3323a05cfe577fb0b389967cd35feb8ae0ca863b9ab02be1af5a60cb5a3901e18321c390377490b5a2449d0fc669d4b581ff19ddbdd9ed6c10215008d7249eb8abdf09263f50dc85a7e45d7df18e46502402e46ba361477eaea258b7e4f0259eaa660a6a30c69030bb2c9770089a12e1d10ff8746d1fdece7de7a332aa14ee74354ac573938c927268445bf90a1e3137347"
(define rsa-key
#"0H\2A\0\257\247\361\314Jm\317w\325OD\223\263\353h\356\300\211Y\16x\344\361\314N\251\t\26\1S\362\222\205,ifN\374\321\230\355\363L\351\311M\255\335\301W\203\177;[\177\272\357\"p\nl\315\216\5\2\3\1\0\1")
;; #"3048024100afa7f1cc4a6dcf77d54f4493b3eb68eec089590e78e4f1cc4ea909160153f292852c69664efcd198edf34ce9c94dadddc157837f3b5b7fbaef22700a6ccd8e050203010001"
(check-equal? (bit-string (123 :: (t:long-ber-tag))) (bytes 123))
(check-equal? (bit-string (234 :: (t:long-ber-tag))) (bytes 129 106))
(check-equal? (bit-string (12345678 :: (t:long-ber-tag))) (bytes 133 241 194 78))
(check-equal? (bit-string-case (bytes 123) ([(v :: (t:long-ber-tag))] v)) 123)
(check-equal? (bit-string-case (bytes 129 106) ([(v :: (t:long-ber-tag))] v)) 234)
(check-equal? (bit-string-case (bytes 133 241 194 78) ([(v :: (t:long-ber-tag))] v)) 12345678)
(check-equal? (bit-string->bytes (bit-string (12 :: (t:ber-length-indicator))))
(bytes 12))
(check-equal? (bit-string->bytes (bit-string (123 :: (t:ber-length-indicator))))
(bytes 123))
(check-equal? (bit-string->bytes (bit-string (1234 :: (t:ber-length-indicator))))
(bytes 130 4 210))
(check-equal? (bit-string->bytes (bit-string (12345678 :: (t:ber-length-indicator))))
(bytes 131 188 97 78))
(check-equal? (bit-string-case (bytes 12) ([(v :: (t:ber-length-indicator))] v)) 12)
(check-equal? (bit-string-case (bytes 123) ([(v :: (t:ber-length-indicator))] v)) 123)
(check-equal? (bit-string-case (bytes 130 4 210) ([(v :: (t:ber-length-indicator))] v)) 1234)
(check-equal? (bit-string-case (bytes 131 188 97 78) ([(v :: (t:ber-length-indicator))] v))
12345678)
(check-equal? (asn1-ber-encode (asn1-ber-decode-all dsa-key)) dsa-key)
(check-equal? (asn1-ber-encode (asn1-ber-decode-all rsa-key)) rsa-key))