;;;; 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 (http-signature asn1)

  #:export (;; this file also provides higher-level functions that produce

            ;; pem-encoded strings from gcrypt keys.

            pem-encode-public

            pem-decode-public))

(define pkcs1-type (asn1:sequence asn1:int-bv asn1:int-bv))

(define pkcs8-type (asn1:sequence (asn1:sequence asn1:object-identifier asn1:null)

                                  asn1:bitstring))

(define (asn.1->string asn)

  "Return the PEM-encoded representation of the @var{asn} record."

  (base64-encode 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."

  (match (canonical-sexp->sexp pk)

    (('public-key ('rsa ('n n) ('e e)))

     (encode-asn1 pkcs1-type (list n 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."

  (match (canonical-sexp->sexp pk)

    (('public-key ('rsa ('n n) ('e e)))

     (encode-asn1 pkcs8-type

                  (list (list (list 1 2 840 113549 1 1 1) #f)

                        (public-key->pkcs1-asn.1 pk))))))

(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->pkcs8-asn.1 public)))

    (string-append

      "-----BEGIN PUBLIC KEY-----\n"

      (cut-str (asn.1->string asn) 64)

      "\n-----END PUBLIC KEY-----")))

(define (decode-pkcs1 der)

  (let ((data (decode-asn1 der pkcs1-type)))

    (match data

      ((n e) (sexp->canonical-sexp `(public-key (rsa (n ,n) (e ,e))))))))

(define (decode-pkcs8 der)

  (let ((data (decode-asn1 der pkcs8-type)))

    (match data

      (((_ _) bs) (decode-pkcs1 bs)))))

(define (pem-decode-public str)

  "Return a public-key from the PEM-encoded key in @var{str}."

  (let* ((lines (string-split str #\newline))

         (first-line (car lines))

         (lines (cdr (reverse (cdr (reverse lines))))))

    (match first-line

      ("-----BEGIN PUBLIC KEY-----"

       (let loop ((content '()) (lines lines))

         (match lines

           (() (throw 'invalid-key))

           ((line lines ...)

            (if (equal? line "-----END PUBLIC KEY-----")

                (decode-pkcs8 (base64-decode (string-join (reverse content) "")))

                (loop (cons line content) lines))))))

      ("-----BEGIN RSA PUBLIC KEY-----"

       (let loop ((content '()) (lines lines))

         (match lines

           (() (throw 'invalid-key))

           ((line lines ...)

            (if (equal? line "-----END RSA PUBLIC KEY-----")

                (decode-pkcs1 (base64-decode (string-join (reverse content) "")))

                (loop (cons line content) lines))))))

      (_ (throw 'unrecognised-key-type)))))