http-signature/http.scm \

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

  #:use-module (gcrypt base64)

  #:use-module (gcrypt hash)

  #:use-module (gcrypt pk-crypto)

  #:use-module (http-signature crypto)

  #:use-module (ice-9 match)

  #:use-module (rnrs bytevectors)

  #:use-module (srfi srfi-19)

  #:use-module (web client)

  #:use-module (web http)

  #:use-module (web uri)

  #:export (http-post/signed

            verify-signed-headers))

(define* (http-post/signed to key keyid #:key (body #f) (verify-certificate? #t)

                           (port (open-socket-for-uri to #:verify-certificate? verify-certificate?))

                           (version '(1 . 1))

                           (keep-alive? #f)

                           (headers '())

                           (decode-body? #t)

                           (streaming? #f))

  (let* ((uri (string->uri to))

         (cur-date (current-date))

         (date (with-output-to-string

                 (lambda _

                   ((header-writer 'date) cur-date (current-output-port)))))

         (signed-data (string-append "(request-target): post "

                                     (uri-path uri) "\nhost: "

                                     (uri-host uri) "\ndate: "

                                     date))

         (public-key (find-sexp-token key 'public-key))

         (private-key (find-sexp-token key 'private-key))

         (data (bytevector->hash-data (sha256 (string->utf8 signed-data))

                                      #:key-type (key-type public-key)))

         (signature-sexp (sign data private-key))

         (signature-bv (match (canonical-sexp->sexp signature-sexp)

                              (('sig-val ('rsa ('s s))) s)))

         (signature (base64-encode signature-bv)))

    (http-post to

               #:body body

               #:verify-certificate? verify-certificate?

               #:port port

               #:keep-alive? keep-alive?

               #:headers

               (cons*

                 `(date . ,cur-date)

                 `(Signature .

                    ,(string-append "keyId=\"" keyid "\",headers=\""

                                    "(request-target) host date\","

                                    "algorithm=\"rsa-sha256\",signature=\""

                                    signature "\""))

                 headers)

               #:decode-body? decode-body?

               #:streaming? streaming?)))

(define (verify-signed-headers headers pubkey-getter method)

  (let* ((signature-header (assoc-ref headers 'Signature))

         (elements (string-split signature-header #\,))

         (elements (map (lambda (elem)

                          (let ((s (string-split elem #\=)))

                            (cons (car s) (string-trim-both

                                            (string-join (cdr s) "=") #\"))))

                        elements))

         (signed-headers (string-split (assoc-ref elements "headers") #\space))

         (keyid (assoc-ref elements "keyId"))

         (signature (assoc-ref elements "signature"))

         (headers (map (lambda (header)

                         (cons header

                               (if (equal? header "(request-target)")

                                   method

                                   (assoc-ref headers (string->symbol header)))))

                       signed-headers))

         (signature-bv (base64-decode signature))

         (signature-sexp (sexp->canonical-sexp `(sig-val (rsa (s ,signature-bv)))))

         (data (map

                 (match-lambda

                   ((header . val)

                    (string-append header ": " val)))

                 headers))

         (data (string-join data "\n"))

         (public-key (pubkey-getter keyid))

         (signed-data

           (bytevector->hash-data (sha256 (string->utf8 data))

                                  #:key-type (key-type public-key))))

    (verify signature-sexp signed-data public-key)))