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