;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>

;;;; 

;;;; This library is free software; you can redistribute it and/or

;;;; modify it under the terms of the GNU Lesser General Public

;;;; License as published by the Free Software Foundation; either

;;;; version 3 of the License, or (at your option) any later version.

;;;; 

;;;; This library is distributed in the hope that it will be useful,

;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

;;;; Lesser General Public License for more details.

;;;; 

;;;; You should have received a copy of the GNU Lesser General Public

;;;; License along with this library; if not, write to the Free Software

;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;;; 

(define-module (http-signature asn1)

  #:use-module (gcrypt base64)

  #:use-module (gcrypt pk-crypto)

  #:use-module (ice-9 match)

  #:use-module (srfi srfi-1)

  #:use-module (srfi srfi-9)

  #:use-module (rnrs bytevectors)

  #:export (asn1-type?

            make-asn1-type

            asn1-type-name

            asn1-type-type

            asn1-type-parser

            asn1-type-producer

            asn1:bool

            asn1:null

            asn1:sequence

            encode-asn1

            decode-asn1))

;; We declare the ASN.1 types here. Each type is associated with its name,

;; its type byte, a parser and a producer.  We will use them to either parse

;; a DER encoded ASN.1 record, or to produce a DER-encoded ASN.1 record.

(define-record-type asn1-type

  (make-asn1-type name type parser producer)

  asn1-type?

  (name asn1-type-name)

  (type asn1-type-type)

  (parser asn1-type-parser)

  (producer asn1-type-producer))

(define asn1:bool

  (make-asn1-type

    "bool" 1

    (lambda (bv pos len)

      (unless (equal? len 1)

        (throw 'invalid-bool-value))

      (let ((val (bytevector-u8-ref bv pos)))

        (not (equal? val 0))))

    (lambda (value)

      (let ((bv (make-bytevector 1)))

        (bytevector-u8-set! bv 0 (if value #xff #x00))

        bv))))

(define asn1:null

  (make-asn1-type

    "null" 5

    (lambda (bv pos len)

      (unless (equal? len 0)

        (throw 'invalid-null-value))

      #nil)

    (lambda (value)

      (make-bytevector 0))))

;; Note that a sequence depends on the types of its contents

(define* (asn1:sequence . types)

  (make-asn1-type

    "sequence" #x30

    (lambda (bv pos len)

      (let loop ((result '()) (types types) (rest-len len) (pos pos))

        (match types

          (()

           (unless (equal? rest-len 0)

             (throw 'invalid-sequence-type))

           (reverse result))

          ((type types ...)

           (match (decode-asn1-aux bv pos type)

             ((value . npos)

              (loop (cons value result) types (- rest-len (- npos pos)) npos)))))))

    (lambda (value)

      (unless (equal? (length value) (length types))

        (throw 'incompatible-type-and-value-sizes))

      (apply

        bv-append

        (map encode-asn1 types value)))))

;; Now these functions are related to parsing or producing DER-encoded values

;; as bytevectors.

(define (decode-asn1-aux bv pos type)

  "Return a value that corresponds to the DER-encoded value of @var{type}

in @var{bv} at @var{pos}.  The return value is a pair of the decoded

value and the new position after reading the bytevector."

  (define (decode-len bv pos)

    (let ((first-byte (bytevector-u8-ref bv pos)))

      (if (> first-byte 127)

        (let ((num-bytes (- first-byte 128)))

          (let loop ((pos (+ pos 1)) (num num-bytes) (result 0))

            (if (eq? num 0)

                result

                (loop (+ pos 1) (- num 1)

                      (+ (bytevector-u8-ref bv pos) (* 256 result))))))

        first-byte)))

  (define (lenlen bv pos)

    (let ((first-byte (bytevector-u8-ref bv pos)))

      (if (> first-byte 127)

          (- first-byte 127); one for the size byte too, so 127 not 128

          1)))

  (let* ((type-byte (bytevector-u8-ref bv pos))

         (pos (+ pos 1))

         (len (decode-len bv pos))

         (pos (+ pos (lenlen bv pos))))

    (unless (equal? type-byte (asn1-type-type type))

      (throw 'invalid-type-byte))

    (cons ((asn1-type-parser type) bv pos len) (+ pos len))))

(define (decode-asn1 bv type)

  "Decode the content of @var{bv}, a DER record of @var{type}"

  (match (decode-asn1-aux bv 0 type)

    ((value . pos) value)))

(define (encode-asn1 type value)

  "Encode the @var{value} of @var{type} into a DER record represented by a

bytevector."

  (let* ((type-byte (asn1-type-type type))

         (value ((asn1-type-producer type) value))

         (len (encode-len (bytevector-length value)))

         (type-bv (make-bytevector 1)))

    (bytevector-u8-set! type-bv 0 type-byte)

    (pk 'encode type-bv len value)

    (bv-append type-bv len value)))

(define (bv-append . bvs)

  "Append multiple bytevectors in a single bytevector."

  (match bvs

    (() (make-bytevector 0))

    ((bv bvs ...)

     (let* ((bvs (apply bv-append bvs))

            (len1 (bytevector-length bv))

            (len2 (bytevector-length bvs))

            (result (make-bytevector (+ len1 len2))))

       (bytevector-copy! bv 0 result 0 len1)

       (bytevector-copy! bvs 0 result len1 len2)

       result))))

(define (encode-len len)

  "Encode the length in a bytevector, following the ASN.1 specification: on 7

bits if it fits, or the first byte has its most significant bit set, and the 7

remaining bits represent the number of bytes needed to represent the length."

  (define (nbytes len)

    "Return the number of bytes needed to represent a number"

    (if (< len 256) 1 (+ 1 (nbytes (quotient len 256)))))

  (let ((bv (make-bytevector (+ 1 (if (> len 127) (nbytes len) 0)))))

    (bytevector-u8-set! bv 0 (if (> len 127) (+ 128 (nbytes len)) len))

    (when (> len 127)

      (let loop ((val len) (pos (- (bytevector-length bv) 1)))

        (when (> val 0)

          (bytevector-u8-set! bv pos (modulo val 256))

          (loop (quotient val 256) (- pos 1)))))

    bv))