;;;; 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))