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-1)
  #: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 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 (rnrs bytevectors)
  #:use-module (oop goops)
  #:declarative? #t
  #:export
  (
   <job>
   description result-box thread
   result join

   <authorization-prompt>
   authorization-uri reason continuation

   <application-state>
   main-account other-accounts client error-messages authorization-prompts running-jobs pages

   add-account
   choose-account
   remove-account
   set-accounts
   set-client
   fold-authorization-prompts
   add-page
   set-page-uri
   close-page
   )
  #:declarative? #t)

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

(define-class <job> ()
  (description #:init-keyword #:description #:getter description)
  (result-box #:init-thunk (lambda () (make-atomic-box #f)) #:getter result-box))

(define-method (equal? (x <job>) (y <job>))
  (and (equal? (description x) (description y))
       (eq? (result-box x) (result-box y))))

(define-method (result (job <job>))
  (atomic-box-ref (result-box job)))

(define-class <authorization-prompt> ()
  (authorization-uri #:init-keyword #:authorization-uri #:getter authorization-uri)
  (reason #:init-keyword #:reason #:getter reason)
  (continuation #:init-keyword #:continuation #:getter continuation))

(define-method (equal? (x <authorization-prompt>) (y <authorization-prompt>))
  (and (equal? (authorization-uri x) (authorization-uri y))
       (equal? (reason x) (reason y))
       (eq? (continuation x) (continuation y))))

(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 '())
  (authorization-prompts
   #:init-keyword #:authorization-prompts
   #:getter authorization-prompts
   #:init-value '())
  (running-jobs
   #:init-keywords #:running-jobs
   #:getter running-jobs
   #:init-value '())
  (pages
   #:init-keyword #:pages
   #:getter pages
   #:init-value '()))

(define-method (equal? (x <application-state>) (y <application-state>))
  (and (equal? (main-account x) (main-account y))
       (equal? (other-accounts x) (other-accounts y))
       (equal? (client x) (client y))
       (equal? (error-messages x) (error-messages y))
       (equal? (authorization-prompts x) (authorization-prompts y))
       (equal? (running-jobs x) (running-jobs y))
       (equal? (pages x) (pages y))))

(define-method (display (state <application-state>) port)
  (format port "#<<application-state> main-account=~a other-accounts=~a client=~a error-messages=~a authorization-prompts=~a running-jobs=~a>"
          (call-with-output-string
            (lambda (port)
              (display (main-account state) port)))
          (call-with-output-string
            (lambda (port)
              (display (map (lambda (acct)
                              (uri->string (account:subject acct)))
                            (other-accounts state))
                       port)))
          (call-with-output-string
            (lambda (port)
              (display (client state) port)))
          (error-messages state)
          (map (lambda (prompt)
                 (uri->string (authorization-uri prompt)))
               (authorization-prompts state))
          (map description (running-jobs state))))

(define-method (join (state <application-state>))
  (let ((ret (shallow-clone state)))
    (receive (finished unfinished)
        (partition result (reverse (running-jobs state)))
      (slot-set! ret 'running-jobs (reverse unfinished))
      (let apply-finished-jobs ((state ret)
                                (jobs (map result finished)))
        (match jobs
          (() state)
          ((#f tl ...)
           (apply-finished-jobs state tl))
          ((hd tl ...)
           (apply-finished-jobs (hd state) tl)))))))

(define-method (add-job (state <application-state>) (description <string>) f)
  (let ((job (make <job> #:description description)))
    (call-with-new-thread
     (lambda ()
       (let ((tag (make-prompt-tag)))
         (atomic-box-set!
          (result-box job)
          ;; The following code returns an updater. The updater takes
          ;; a previous state and returns a new state.
          ;;
          ;; There are 2 possible branches:
          ;;
          ;; 1. If everything works, the updater is what’s returned by
          ;; (f);
          ;;
          ;; 2. If (f) calls the authorization process, the updater is
          ;; a function that adds an authorization prompts to further
          ;; continue the call in a new job. In that case, continuing
          ;; yields an updater too, because it is delimited by this
          ;; prompt.
          (call-with-prompt tag
            (lambda ()
              (parameterize
                  ((client:client (client state))
                   (account:authorization-process
                    (lambda* (uri #:key (reason #f))
                      (abort-to-prompt
                       tag
                       (lambda (continuation)
                         ;; This is a state updating function. It just
                         ;; registers the continuation as a new
                         ;; authorization prompt.
                         (lambda (previous-state)
                           ;; This code runs in the main thread.
                           (define (continue state code)
                             (add-job state description
                                      (lambda ()
                                        (continuation code))))
                           (let ((ret (shallow-clone previous-state)))
                             (slot-set! ret 'authorization-prompts
                                        `(,(make <authorization-prompt>
                                             #:authorization-uri uri
                                             #:reason reason
                                             #:continuation continue)
                                          ,@(authorization-prompts previous-state)))
                             ret)))))))
                (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))))))
                  (lambda ()
                    (f)))))
            (lambda (continuation get-updater)
              (get-updater continuation)))))))
    (let ((ret (shallow-clone state)))
      (slot-set! ret 'running-jobs `(,job ,@(running-jobs ret)))
      ret)))

(define-method (add-account (state <application-state>) issuer)
  (add-job
   state
   (format #f (G_ "Add an account on ~a")
           (uri->string issuer))
   (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? (account:subject current-main-account) (account:subject new-account))
                        (equal? (account:issuer current-main-account) (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 (account:subject new-account))
                                           (uri->string (account: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? (account:subject existing) (account:subject new-account))
                                 (equal? (account:issuer existing) (account: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 (account:subject new-account))
                                                    (uri->string (account:issuer new-account)))))
                              ret)
                            (check other))))))
               ;; No main account yet
               (let ((ret (shallow-clone previous-state)))
                 (slot-set! ret 'main-account new-account)
                 ret))))))))

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

(define-method (remove-account (state <application-state>) (account <account:account>))
  (let ((ret (shallow-clone state)))
    (let ((main (main-account ret))
          (other (other-accounts ret)))
      (let* ((all `(,main ,@other))
             (kept (filter (lambda (a) (not (equal? a account))) all)))
        (match kept
          (()
           (slot-set! ret 'main-account #f)
           (slot-set! ret 'other-accounts '()))
          ((main other ...)
           (slot-set! ret 'main-account main)
           (slot-set! ret 'other-accounts other)))))
    ret))

(define-method (set-accounts (state <application-state>) (accounts <list>))
  (let ((ret (shallow-clone state)))
    (match accounts
      (()
       (slot-set! ret 'main-account #f)
       (slot-set! ret 'other-accounts '()))
      ((main other ...)
       (slot-set! ret 'main-account main)
       (slot-set! ret 'other-accounts other)))
    ret))

(define-method (set-accounts (state <application-state>) (main <account:account>) (other <list>))
  (set-accounts state `(,main ,@other)))

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

(define-method (fold-authorization-prompts (state <application-state>) f seed)
  (let iter ((prompts (reverse (authorization-prompts state)))
             (seed seed)
             (state
              (let ((ret (shallow-clone state)))
                (slot-set! ret 'authorization-prompts '())
                ret)))
    (match prompts
      (()
       (values seed state))
      ((prompt prompts ...)
       (receive (seed code) (f seed (authorization-uri prompt))
         (let ((state
                ;; If I have a code, transform state by calling the
                ;; continuation function (i.e., add a job that will
                ;; finish the task). If I don’t, I need to keep this
                ;; prompt around.
                (if code
                    ((continuation prompt) state code)
                    (let ((with-unresolved-prompt (shallow-clone state)))
                      (slot-set! ret 'authorization-prompts
                                 `(,prompt ,@(authorization-prompts state)))
                      with-unresolved-prompt))))
           (iter prompts seed state)))))))

(define-class <page> ()
  (identifier #:init-keyword #:identifier #:getter identifier))

(define-method (equal? (x <page>) (y <page>))
  (and (equal? (identifier x) (identifier y))))

(define-class <new-page> (<page>))

(define-class <page-with-uri> (<page>)
  (uri #:init-keyword #:uri #:getter uri))

(define-method (equal? (x <page-with-uri>) (y <page-with-uri>))
  (and (equal? (uri x) (uri y))))

(define-class <loading-page> (<page-with-uri>))

(define-class <error-page> (<page-with-uri>)
  (code #:init-keyword #:code #:getter code)
  (reason-phrase #:init-keyword #:reason-phrase #:getter reason-phrase))

(define-method (equal? (x <error-page>) (y <error-page>))
  (and (equal? (code x) (code y))
       (equal? (reason-phrase x) (reason-phrase y))))

(define-class <loaded-page> (<page-with-uri>)
  (etag #:init-keyword #:etag #:getter etag)
  (links #:init-keyword #:links #:getter links))

(define-method (equal? (x <loaded-page>) (y <loaded-page>))
  (and (equal? (etag x) (etag y))
       (equal? (links x) (links y))))

(define-class <rdf-page> (<loaded-page>)
  (triples #:init-keyword #:triples #:getter triples))

(define-method (equal? (x <rdf-page>) (y <rdf-page>))
  (and (equal? (triples x) (triples y))))

(define-class <non-rdf-page> (<loaded-page>)
  (content-type #:init-keyword #:content-type #:getter content-type)
  (content #:init-keyword #:content #:getter content))

(define-method (equal? (x <non-rdf-page>) (y <non-rdf-page>))
  (and (equal? (content-type x) (content-type y))
       (equal? (content x) (content y))))

(define-method (add-page (state <application-state>) (identifier <string>))
  (let ((ret (shallow-clone state)))
    (slot-set! ret 'pages
               `(,(make <new-page> #:identifier identifier)
                 ,@(pages state)))
    ret))

(define-method (set-page-uri (state <application-state>) (id <string>) uri)
  (let ((ret (shallow-clone state)))
    (slot-set! ret 'pages
               (let replace-page ((pages (pages state))
                                  (untouched-pages '()))
                 (match pages
                   (()
                    (reverse untouched-pages))
                   ((hd tl ...)
                    (let ((replaced
                           (if (equal? (identifier hd) id)
                               (make <loading-page>
                                           #:identifier id
                                           #:uri uri)
                               hd)))
                      (replace-page
                       tl
                       `(,replaced
                         ,@(untouched-pages))))))))
    ;; TODO: add a job to load the page…
    ret))

(define-method (close-page (state <application-state>) (id <string>))
  (let ((ret (shallow-clone state)))
    (slot-set! ret 'pages
               (filter (lambda (page)
                         (not (equal? (identifier page) id)))
                       (pages state)))
    ret))