;; webid-oidc, implementation of the Solid specification
;; Copyright (C) 2020, 2021  Vivien Kraus

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.

;; This program 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 Affero General Public License for more details.

;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

(define-module (webid-oidc stubs)
  #:use-module (webid-oidc config)
  #:use-module (webid-oidc errors)
  #:use-module (json))

(load-extension
 (format #f "~a/libwebidoidc" libdir)
 "init_webidoidc")

(define (fix-base64-decode data)
  (catch 'base64-decoding-error
    (lambda ()
      (base64-decode data))
    (lambda error
      (raise-not-base64 data error))))

(define (fix-generate-key . args)
  (catch 'unsupported-crv
    (lambda ()
      (apply generate-key args))
    (lambda (error)
      (raise-unsupported-crv (cadr error)))))

(define (fix-kty key)
  (catch 'unsupported-crv
    (lambda ()
      (let ((ret (kty key)))
        (unless ret
          (raise-not-a-jwk key #f))
        ret))
    (lambda error
      (raise-unsupported-crv (cadr error)))))

(define (fix-hash alg payload)
  (catch 'unsupported-alg
    (lambda ()
      (hash alg payload))
    (lambda error
      (raise-unsupported-alg (cadr error)))))

(define (fix-sign alg key payload)
  (catch 'unsupported-alg
    (lambda ()
      (sign alg key payload))
    (lambda error
      (raise-unsupported-alg (cadr error)))))

(define (fix-verify alg key payload signature)
  (catch 'unsupported-alg
    (lambda ()
      (let ((ok
             (verify alg key payload signature)))
        (unless ok
          (raise-invalid-signature key payload signature))))
    (lambda error
      (raise-unsupported-alg (cadr error)))))

(export
 base64-encode
 (fix-base64-decode . base64-decode)
 random
 random-init!
 (fix-generate-key . generate-key)
 (fix-kty . kty)
 strip-key
 (fix-hash . hash)
 jkt
 (fix-sign . sign)
 (fix-verify . verify))

;; json reader from guile-json will not behave consistently with
;; SRFI-180 with objects: keys will be mapped to strings, not
;; symbols. So we fix alist keys to be symbols.
(define-public (fix-alists data)
  (define (fix-an-alist rest alist)
    (if (null? alist)
        (reverse rest)
        (let ((k/v (car alist))
              (tail (cdr alist)))
          (let ((key (car k/v))
                (value (cdr k/v)))
            (fix-an-alist
             (acons (string->symbol key)
                    (fix-alists value)
                    rest)
             tail)))))
  (define (fix-a-vector vec)
    (list->vector
     (map fix-alists
          (vector->list vec))))
  (cond
   ((list? data)
    (fix-an-alist '() data))
   ((vector? data)
    (fix-a-vector data))
   (else data)))

(define (fixed:json-string->scm str)
  (with-exception-handler
      (lambda (err)
        (raise-not-json str err))
    (lambda ()
      (fix-alists (json-string->scm str)))))

(export (fixed:json-string->scm . json-string->scm))

(define (fixed:json->scm port)
  (with-exception-handler
      (lambda (err)
        (raise-not-json "(input)" err))
    (lambda ()
      (fix-alists (json->scm port)))))

(export (fixed:json->scm . json->scm))

(define fixed:scm->json-string scm->json-string)

(export (fixed:scm->json-string . scm->json-string))

(define fixed:scm->json scm->json)

(export (fixed:scm->json . scm->json))

(define-public (mkdir-p name)
  (catch 'system-error
    (lambda ()
      (mkdir name))
    (lambda (key subr message args rest)
      (case (car rest)
        ((17) ;; file exists
         #t)
        ((2) ;; parent does not exist
         (let ((parent (dirname name)))
           (unless (equal? parent name)
             (mkdir-p parent))
           (mkdir name)))
        (else
         (throw key subr message args rest))))))

(define-public (open-output-file* filename . args)
  (mkdir-p (dirname filename))
  (apply open-output-file filename args))

(define-public (call-with-output-file* filename . args)
  (mkdir-p (dirname filename))
  (apply call-with-output-file filename args))

(define-public (atomically-update-file file lock-file-name f)
  ;; Call f with an output port. If f returns #f, delete the original
  ;; file. Otherwise, replace it.
  (let ((updating-file-name (string-append file "~")))
    (mkdir-p (dirname updating-file-name))
    (call-with-output-file lock-file-name
      (lambda (port)
        (define (enter)
          (flock port LOCK_EX))
        (define (leave)
          (flock port LOCK_UN))
        (dynamic-wind
          enter
          (lambda ()
            (call-with-output-file updating-file-name
              (lambda (port)
                (truncate-file port 0)
                (with-exception-handler
                    (lambda (error)
                      (false-if-exception (delete-file updating-file-name))
                      (raise-exception error))
                  (lambda ()
                    (let ((ok (f port)))
                      (fsync port)
                      (close-port port)
                      (if ok
                          (rename-file updating-file-name file)
                          ;; f asked us to delete the original file
                          (begin
                            (false-if-exception
                             (delete-file file))
                            (false-if-exception
                             (delete-file updating-file-name))))))))))
          leave)))))