path: root/src/scm/webid-oidc/stubs.scm

;; disfluid, 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 (ice-9 exceptions)
  #:use-module (ice-9 i18n)
  #:use-module (webid-oidc parameters)
  #:use-module (json)
  #:export
  (

   &invalid-base64-data
   make-invalid-base64-data
   invalid-base64-data?
   error-base64-data

   &unsupported-elliptic-curve
   make-unsupported-elliptic-curve
   unsupported-elliptic-curve?
   unsupported-elliptic-curve-value

   &unsupported-algorithm
   make-unsupported-algorithm
   unsupported-algorithm?
   unsupported-algorithm-alg
   unsupported-algorithm-application

   &invalid-signature
   make-invalid-signature
   invalid-signature?
   invalid-signature-alg
   invalid-signature-key
   invalid-signature-payload
   invalid-signature-signature

   &invalid-json
   make-invalid-json
   invalid-json?
   invalid-json-input
   
   base64-encode
   (fix-base64-decode . base64-decode)
   random
   (fix-random-init! . random-init!)
   (fix-generate-key . generate-key)
   kty
   strip-key
   (fix-hash . hash)
   jkt
   (fix-sign . sign)
   (fix-verify . verify)
   (fixed:json-string->scm . json-string->scm)
   (fixed:json->scm . json->scm)
   (fixed:scm->json-string . scm->json-string)
   (fixed:scm->json . scm->json)

   mkdir-p
   open-output-file*
   call-with-output-file*
   atomically-update-file
   
   ))

(define (G_ text)
  (let ((out (gettext text)))
    (if (string=? out text)
        ;; No translation, disambiguate
        (car (reverse (string-split text #\|)))
        out)))

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

(define-exception-type
  &invalid-base64-data
  &external-error
  make-invalid-base64-data
  invalid-base64-data?
  (data error-base64-data))

(define (summarize str)
  (if (> (string-length str) 10)
      (format #f "~s"
              (string-append
               (substring str 0 10)
               "..."))
      (format #f "~s" str)))

(define (fix-base64-decode data)
  (catch 'base64-decoding-error
    (lambda ()
      (base64-decode data))
    (lambda error
      (let ((final-message
             (format #f (G_ "invalid base64 data: ~a")
                     (summarize data))))
        (raise-exception
         (make-exception
          (make-invalid-base64-data data)
          (make-exception-with-message final-message)
          (make-exception-with-irritants (list data))))))))

(define-exception-type
  &unsupported-elliptic-curve
  &external-error
  make-unsupported-elliptic-curve
  unsupported-elliptic-curve?
  (curve unsupported-elliptic-curve-value))

(define (unsupported-crv crv)
  (let ((final-message
         (format #f (G_ "~s is not a recognized elliptic curve")
                 crv)))
    (raise-exception
     (make-exception
      (make-unsupported-elliptic-curve crv)
      (make-exception-with-message final-message)
      (make-exception-with-irritants (list crv))))))

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

(define-exception-type
  &unsupported-algorithm
  &external-error
  make-unsupported-algorithm
  unsupported-algorithm?
  (alg unsupported-algorithm-alg)
  ;; 'sign or 'hash:
  (application unsupported-algorithm-application))

(define (unsupported-alg alg application)
  (let ((final-message
         (case application
           ((sign)
            (format #f (G_ "~s is not a supported signature algorithm")
                    alg))
           ((hash)
            (format #f (G_ "~s is not a supported hash algorithm")
                    alg)))))
    (raise-exception
     (make-exception
      (make-unsupported-algorithm alg application)
      (make-exception-with-message final-message)
      (make-exception-with-irritants (list alg))))))

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

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

(define-exception-type
  &invalid-signature
  &external-error
  make-invalid-signature
  invalid-signature?
  (alg invalid-signature-alg)
  (key invalid-signature-key)
  (payload invalid-signature-payload)
  (signature invalid-signature-signature))

(define (fix-verify alg key payload signature)
  (catch 'unsupported-alg
    (lambda ()
      (let ((ok (verify alg key payload signature)))
        (unless ok
          (let ((final-message
                 (format #f (G_ "the signature is invalid"))))
            (raise-exception
             (make-exception
              (make-invalid-signature alg key payload signature)
              (make-exception-with-message final-message)
              (make-exception-with-irritants (list alg key payload signature))))))))
    (lambda error
      (unsupported-alg alg 'sign))))

(define (fix-random-init!)
  (setenv "XDG_CACHE_HOME" (cache-home))
  (setenv "DISFLUID_APPLICATION_NAME" ".")
  (random-init!))

;; 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 (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-exception-type
  &invalid-json
  &external-error
  make-invalid-json
  invalid-json?
  (input invalid-json-input))

(define (fixed:json-string->scm str)
  (with-exception-handler
      (lambda (exn)
        (let ((final-message
               (format #f (G_ "invalid JSON data: ~a")
                       (summarize str))))
          (raise-exception
           (make-exception
            (make-invalid-json str)
            (make-exception-with-message final-message)
            (make-exception-with-irritants (list str))
            exn))))
    (lambda ()
      (fix-alists (json-string->scm str)))))

(define (fixed:json->scm port)
  (with-exception-handler
      (lambda (exn)
        (let ((final-message 
               (format #f (G_ "invalid JSON data in input port"))))
          (raise-exception
           (make-exception
            (make-invalid-json "(input)")
            (make-exception-with-message final-message)
            (make-exception-with-irritants (list port))
            exn))))
    (lambda ()
      (fix-alists (json->scm port)))))

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

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

(define (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 (open-output-file* filename . args)
  (mkdir-p (dirname filename))
  (apply open-output-file filename args))

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

(define (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))
                      (let ((final-message
                             (if (exception-with-message? error)
                                 (format #f (G_ "while updating file ~s: ~a")
                                         file (exception-message error))
                                 (format #f (G_ "an error happened while updating file ~s")
                                         file))))
                        (raise-exception
                         (make-exception
                          (make-exception-with-message final-message)
                          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)))))