;;;; 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 crypto)
  #: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 (;; this file provides some functions to deal with asn.1, der and pem.
            asn.1?
            make-asn.1
            asn.1-type
            asn.1-len
            asn.1-val

            asn.1-compute-len
            asn.1->bv
            ;; this file also provides higher-level functions that produce
            ;; pem-encoded strings from gcrypt keys.
            pem-encode-public))

(define-record-type asn.1
  (make-asn.1 type len val)
  asn.1?
  (type asn.1-type)
  (len  asn.1-len)
  (val  asn.1-val))

(define (asn.1-compute-len asn)
  "Computes the length of values in an asn.1 record.  Return that record, where
lengths are updated."
  (match asn
    (($ asn.1 type len val)
     (match type
       ('bool
        (match val
          ((? boolean? val)
           (make-asn.1 type 1 val))))
       ('int
        (match val
         ((? bytevector? val)
          (make-asn.1 type (bytevector-length val) val))))
       ('null
        (make-asn.1 type 0 val))
       ('sequence
        (let ((nval (map asn.1-compute-len val)))
          (make-asn.1 type (fold + 0 (map asn.1-full-length nval)) nval)))))))

(define (asn.1-full-length asn)
  "Compute the length of an asn.1 record, including the length of its length
field."
  (match asn
    (($ asn.1 type len val)
     (+ len 1 1 (if (> len 127) (nbits len) 0)))))

(define (nbits len)
  (if (< len 256) 1 (+ 1 (nbits (quotient len 256)))))

(define (asn.1->bv asn)
  "Take an asn.1 where lengths are computed and returns a bytevector that
corresponds to the DER encoding of that content."
  (let ((bv (make-bytevector (asn.1-full-length asn))))
    (match asn
      (($ asn.1 type len val)
       (let ((val-pos (if (> len 127) (+ 2 (nbits len)) 2)))
         (bytevector-u8-set! bv 1 (if (> len 127) (+ 128 (nbits len)) len))
         (when (> len 127)
           (let loop ((val len) (pos (- val-pos 1)))
             (when (> val 0)
               (bytevector-u8-set! bv pos (modulo val 256))
               (loop (quotient val 256) (- pos 1)))))
         (match type
           ('bool
            (begin
              (bytevector-u8-set! bv 0 #x01)
              (bytevector-u8-set! bv val-pos (if val 255 0))))
           ('int
            (begin
              (bytevector-u8-set! bv 0 #x02)
              (bytevector-copy! val 0 bv val-pos (bytevector-length val))))
           ('null
            (bytevector-u8-set! bv 0 #x05))
           ('sequence
            (begin
              (bytevector-u8-set! bv 0 #x30)
              (let loop ((val (map asn.1->bv val)) (pos val-pos))
                (when (not (null? val))
                  (bytevector-copy! (car val) 0 bv pos (bytevector-length (car val)))
                  (loop (cdr val) (+ pos (bytevector-length (car val))))))))))))
    bv))

(define (asn.1->string asn)
  "Return the PEM-encoded representation of the @var{asn} record."
  (base64-encode (asn.1->bv asn)))

(define (public-key->pkcs1-asn.1 pk)
  "Return the ASN.1 representation of @var{pk}, an RSA public key, using the
PKCS#1 representation."
  (asn.1-compute-len
    (match (canonical-sexp->sexp pk)
      (('public-key ('rsa ('n n) ('e e)))
       (make-asn.1
         'sequence #f
         (list
           (make-asn.1 'int #f n)
           (make-asn.1 'int #f e))))))))

(define (public-key->pkcs8-asn.1 pk)
  "Return the ASN.1 representation of @var{pk}, a public key, using the PKCS#8
representation.  Currently only RSA keys can be transformed."
  (asn.1-compute-len
    (match (canonical-sexp->sexp pk)
      (('public-key ('rsa ('n n) ('e e)))
       (make-asn.1
         'sequence #f
         (list
           (make-asn.1)
           (make-asn.1))))))

(define (cut-str str n)
  "Cut a string @var{str} at @var{n} characters by placing a @code{\\n}, so that
the string is aligned to @var{n} characters."
  (let loop ((str str))
    (if (< (string-length str) (+ n 1))
        str
        (string-append
          (substring str 0 n)
          "\n"
          (loop (substring str n))))))

(define (pem-encode-public keypair)
  "Return the PEM-encoded version of the public key in @var{keypair}, an RSA
keypair."
  (let* ((public (find-sexp-token keypair 'public-key))
         (asn (public-key->pkcs1-asn.1 public)))
    (string-append
      "-----BEGIN RSA PUBLIC KEY-----\n"
      (cut-str (asn.1->string asn) 64)
      "\n-----END RSA PUBLIC KEY-----")))