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