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