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

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

   add-account
   choose-account
   set-client
   fold-authorization-prompts
   add-page
   set-page-uri
   close-page

   ->sexp
   )
  #: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 (result (job <job>))
  (atomic-box-ref (result-box job)))

(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 with the
  ;; authorization code. The procedure takes 2 arguments: the code and
  ;; a state, and it returns the updated state.
  (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 (->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 running-jobs=~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))
          (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)
          ((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)))
         (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
                                       `((,uri . ,continue)
                                         ,@(authorization-prompts previous-state)))
                            ret)))))))
               (cache:use-cache
                (lambda ()
                  (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 ()
                      (let ((updater (f)))
                        (atomic-box-set! (result-box job) updater))))))))
           (lambda (continuation get-updater)
             (atomic-box-set! (result-box job) (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? (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 <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)))))
    ret))

(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))
      (((uri . continue) prompts ...)
       (receive (seed code) (f seed uri)
         (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
                    (continue state code)
                    (let ((with-unresolved-prompt (shallow-clone state)))
                      (slot-set! ret 'authorization-prompts
                                 `((,uri . ,continue) ,@(authorization-prompts state)))
                      with-unresolved-prompt))))
           (iter prompts seed state)))))))

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

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

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

(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-class <loaded-page> (<page-with-uri>)
  (etag #:init-keyword #:etag #:getter etag)
  (links #:init-keyword #:links #:getter links))

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

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

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