path: root/src/scm/webid-oidc/client/application.scm

;; disfluid, implementation of the Solid specification
;; Copyright (C) 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 client application)
  #:use-module (ice-9 match)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 i18n)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 futures)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 atomic)
  #:use-module (ice-9 pretty-print)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-19)
  #:use-module (webid-oidc errors)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module ((webid-oidc oidc-id-token) #:prefix id:)
  #:use-module ((webid-oidc oidc-configuration) #:prefix cfg:)
  #:use-module ((webid-oidc jwk) #:prefix jwk:)
  #:use-module ((webid-oidc dpop-proof) #:prefix dpop:)
  #:use-module ((webid-oidc client client) #:prefix client:)
  #:use-module ((webid-oidc client accounts) #:prefix account:)
  #:use-module ((webid-oidc cache) #:prefix cache:)
  #:use-module (webid-oidc web-i18n)
  #:use-module (web uri)
  #:use-module (web response)
  #:use-module (web client)
  #:use-module (rnrs bytevectors)
  #:use-module (oop goops)
  #:declarative? #t
  #:export
  (
   <application-state>
   main-account other-accounts client error-messages authorization-prompts
   
   <multitask-application-state>
   current-state pending-operations

   check-pending-operations
   add-account
   choose-account
   set-client
   process-authorization-prompts

   ->sexp
   )
  #:declarative? #t)

(define <client:client> client:<client>)
(define <account:account> account:<account>)

(define-class <application-state> ()
  (main-account
   #:init-keyword #:main-account
   #:getter main-account
   #:init-value #f)
  (other-accounts
   #:init-keyword #:other-accounts
   #:getter other-accounts
   #:init-value '())
  (client
   #:init-keyword #:client
   #:getter client
   #:init-thunk (lambda ()
                  (make <client:client>
                    #:client-id
                    "https://webid-oidc-demo.planete-kraus.eu/example-application#id"
                    #:redirect-uri
                    "https://webid-oidc-demo.planete-kraus.eu/authorized")))
  (error-messages
   #:init-keyword #:error-messages
   #:getter error-messages
   #:init-value '())
  ;; This is a list of pairs: URI * procedure to call on the
  ;; authorization code
  (authorization-prompts
   #:init-keyword #:authorization-prompts
   #:getter authorization-prompts
   #:init-value '()))

(define-method (->sexp (state <application-state>))
  `(begin
     (use-modules (oop goops) (webid-oidc client application))
     (make <application-state>
       ,@(let ((main-account (main-account state)))
           (if main-account
               `(#:main-account ,(account:->sexp main-account))
               '()))
       #:other-accounts (list ,@(map account:->sexp (other-accounts state)))
       ,@(let ((client (client state)))
           (if client
               `(#:client ,(client:->sexp client))
               '()))
       #:error-messages (list ,@(error-messages state)))))

(define-method (write (state <application-state>) port)
  (pretty-print (->sexp state) port))

(define-method (display (state <application-state>) port)
  (format port "#<<application-state> main-account=~a client=~a error-messages=~a authorization-prompts=~a>"
          (call-with-output-string
            (lambda (port)
              (display (main-account state) port)))
          (call-with-output-string
            (lambda (port)
              (display (client state) port)))
          (error-messages state)
          (map (match-lambda (((= uri->string uri) . _) uri))
               (authorization-prompts state))))

(define-class <multitask-application-state> ()
  (current-state
   #:init-keyword #:current-state
   #:getter current-state
   #:init-thunk (lambda () (make <application-state>)))
  ;; This is an atomic box to a list of state -> state functions that
  ;; should be executed as soon as possible, in reverse order.
  (pending-operations
   #:init-keyword #:pending-operations
   #:getter pending-operations
   #:init-thunk (lambda () (make-atomic-box '()))))

(define-method (->sexp (state <multitask-application-state>))
  `(begin
     (use-modules (oop goops) (webid-oidc client application))
     (make <multitask-application-state>
       #:current-state ,(->sexp (current-state state)))))

(define-method (write (state <multitask-application-state>) port)
  (pretty-print (->sexp state) port))

(define-method (display (state <multitask-application-state>) port)
  (format port "#<<multitask-application-state> current-state=~a n-pending-operations=~a>"
          (call-with-output-string
            (lambda (port)
              (display (current-state state) port)))
          (length (atomic-box-ref (pending-operations state)))))

(define-method (check-pending-operations (state <multitask-application-state>))
  (let steal-pending-operations ()
    (let* ((box (pending-operations state))
           (stolen-pending-operations
            (atomic-box-ref (pending-operations state)))
           (confirmed-pending-operations
            (atomic-box-compare-and-swap! box stolen-pending-operations '())))
      (if (eq? stolen-pending-operations confirmed-pending-operations)
          (let apply-all ((state (current-state state))
                          (ops (reverse stolen-pending-operations)))
            (match ops
              (()
               (make <multitask-application-state>
                 #:current-state state
                 #:pending-operations box))
              ((hd tl ...)
               (apply-all (hd state) tl))))
          ;; Concurrent update, retry
          (steal-pending-operations)))))

(define-method (push-pending-operation (state <multitask-application-state>) f)
  (let ((other-pending-operations
         (atomic-box-ref (pending-operations state))))
    (let ((confirmed (atomic-box-compare-and-swap!
                      (pending-operations state)
                      other-pending-operations
                      `(,f ,@other-pending-operations))))
      (unless (eq? confirmed other-pending-operations)
        ;; Retry
        (push-pending-operation state f)))))

(define http-request-with-cache
  (let ((default-http-get-with-cache (cache:with-cache)))
    (lambda* (uri . all-args)
      (let try-get-with-cache ((args all-args)
                               (args-for-get '()))
        (match args
          (()
           (apply default-http-get-with-cache uri (reverse args-for-get)))
          ((#:headers arg other-args ...)
           (try-get-with-cache other-args `(,arg #:headers ,@args-for-get)))
          ((#:method 'GET other-args ...)
           (try-get-with-cache other-args args-for-get))
          (else
           (apply http-request uri all-args)))))))

(define-method (run-async (state <multitask-application-state>) f)
  (call-with-new-thread
   (lambda ()
     (let ((tag (make-prompt-tag)))
       (define (handle-authorization-prompts f)
         (call-with-prompt tag
           (lambda ()
             (parameterize
                 ((client:client (client (current-state state)))
                  (account:authorization-process
                   (lambda* (uri #:key issuer)
                     (abort-to-prompt
                      tag
                      (lambda (continuation)
                        ;; This is a state updating function. It just
                        ;; registers the continuation as a new
                        ;; authorization prompt.
                        (define (continuation-with-dynamic-state authorization-code)
                          (handle-authorization-prompts
                           (lambda ()
                             (continuation authorization-code))))
                        (lambda (previous-state)
                          ;; This code is ran in the main thread.
                          (let ((ret (shallow-clone previous-state)))
                            (slot-set! ret 'authorization-prompts
                                       `((,uri . ,continuation-with-dynamic-state)
                                         ,@(authorization-prompts previous-state)))
                            ret))))))
                  (account:anonymous-http-request http-request-with-cache))
               (with-exception-handler
                   (lambda (exn)
                     (let ((msg (if (exception-with-message? exn)
                                    (exception-message exn)
                                    (format #f "~s" exn))))
                       (abort-to-prompt
                        tag
                        (lambda (_)
                          ;; We won’t continue, but we will show the error message
                          (lambda (previous-state)
                            (let ((ret (shallow-clone previous-state)))
                              (slot-set! ret 'error-messages
                                         `(,msg ,@(error-messages previous-state)))
                              ret))))))
                 f)))
           (lambda (continuation get-updater)
             (push-pending-operation state (get-updater continuation)))))
       (handle-authorization-prompts
        (lambda ()
          (let ((updater (f)))
            (push-pending-operation state updater))))))))

(define-method (add-account (state <multitask-application-state>) issuer)
  (run-async
   state
   (lambda ()
     (let ((new-account (make <account:account> #:issuer issuer)))
       ;; The updater either sets the main account, or adds it to the
       ;; other accounts. If there is already an account with the same
       ;; subject and issuer, print an error message instead.
       (lambda (previous-state)
         (let ((current-main-account (main-account previous-state)))
           (if current-main-account
               (if (and (equal? (subject current-main-account) (subject new-account))
                        (equal? (issuer current-main-account) (issuer new-account)))
                   ;; First kind of duplicate
                   (let ((ret (shallow-clone previous-state)))
                     (slot-set! ret 'error-messages
                                `(,(format #f (G_ "You already have an account for ~a issued by ~a and it is currently selected.")
                                           (uri->string (subject new-account))
                                           (uri->string (issuer new-account)))))
                     ret)
                   ;; The main account slot is already taken, add it to the other accounts
                   (let check ((other (other-accounts previous-state)))
                     (match other
                       (()
                        ;; The account does not already exist
                        (let ((ret (shallow-clone previous-state)))
                          (slot-set! ret 'other-accounts
                                     `(,new-account ,@(other-accounts previous-state)))
                          ret))
                       ((existing other ...)
                        (if (and (equal? (subject existing) (subject new-account))
                                 (equal? (issuer existing) (issuer new-account)))
                            ;; Second kind of duplicate
                            (let ((ret (shallow-clone previous-state)))
                              (slot-set! ret 'error-messages
                                         `(,(format #f (G_ "You already have an account for ~a issued by ~a.")
                                                    (uri->string (subject new-account))
                                                    (uri->string (issuer new-account)))))
                              ret)
                            (check other))))))
               ;; No main account yet
               (let ((ret (shallow-clone previous-state)))
                 (slot-set! ret 'main-account new-account)
                 ret)))))))
  state)

(define-method (choose-account (state <multitask-application-state>) (account <account:account>))
  (let ((ret (shallow-clone state)))
    (let ((new-state
           (let ((current (shallow-clone (current-state state))))
             (slot-set! current 'main-account account)
             (slot-set! current 'other-accounts
                        (filter (lambda (other)
                                  (not (equal? other account)))))
             current)))
      (slot-set! ret 'current-state new-state))
    ret))

(define-method (set-client (state <multitask-application-state>) (client <client:client>))
  (let ((ret (shallow-clone state)))
    (let ((new-state
           (let ((current (shallow-clone (current-state state))))
             (slot-set! current 'client client)
             current)))
      (slot-set! ret 'current-state new-state))
    ret))

(define-method (process-authorization-prompts (state <application-state>) f seed)
  (let iter ((prompts (authorization-prompts state))
             (unsolved '())
             (seed seed))
    (match prompts
      (()
       (let ((ret (shallow-clone state)))
         (slot-set! ret 'authorization-prompts
                    (reverse unsolved))
         (values seed ret)))
      (((uri . continue) prompts ...)
       (receive (seed code) (f seed uri)
         (when code
           (continue code))
         (iter prompts
               (if code
                   unsolved
                   `((,uri . ,continue) ,@unsolved))
               seed))))))

(define-method (process-authorization-prompts (state <multitask-application-state>) f seed)
  (let ((ret (shallow-clone state)))
    (receive (seed new-state)
        (process-authorization-prompts (current-state state) f seed)
      (slot-set! ret 'current-state new-state)
      (values seed ret))))