;; 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 (srfi srfi-26)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc http-link)
  #: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) #: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 page

   <page>
   <new-page>
   <page-with-uri> uri
   <loading-page>
   <error-page> code reason-phrase
   <loaded-page> etag links content-type content
   <updated-page> desired-links desired-content-type desired-content

   add-account
   choose-account
   remove-account
   set-accounts
   set-client
   fold-authorization-prompts
   set-page-uri
   edit-page
   remove-link
   add-link
   change-content-type
   change-content
   discard-updates
   commit-updates
   delete-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 '())
  (page
   #:init-keyword #:page
   #:getter page
   #:init-thunk
   (lambda ()
     (make <new-page>))))

(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? (page x) (page 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! with-unresolved-prompt 'authorization-prompts
                                 `(,prompt ,@(authorization-prompts state)))
                      with-unresolved-prompt))))
           (iter prompts seed state)))))))

(define-class <page> ())

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

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

(define-method (initialize (page <page-with-uri>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((uri #f))
   (let do-initialize ((uri uri))
     (match uri
       ((or (? string? (= string->uri (? uri? uri)))
            (? uri? uri)
            (? string?
               (= (cute string-append "https://" <>)
                  (= string->uri (? uri? uri)))))
        (slot-set! page 'uri uri))
       (else
        (scm-error 'wrong-type-arg "make <page-with-uri>"
                   (G_ "the page URI (#:uri) should be a string encoding an URI or an URI")
                   '()
                   (list 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 (initialize (page <error-page>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((code #f)
    (reason-phrase #f))
   (let do-initialize ((code code)
                       (reason-phrase reason-phrase))
     (match `(,code ,reason-phrase)
       (((? integer? code) (? string? reason-phrase))
        (slot-set! page 'code code)
        (slot-set! page 'reason-phrase reason-phrase))
       (else
        (scm-error 'wrong-type-arg "make <error-page>"
                   (G_ "the error code (#:code) should be an integer and the reason phrase (#:reason-phrase) should be a string")
                   '()
                   (list code reason-phrase)))))))

(define-method (equal? (x <error-page>) (y <error-page>))
  (and (equal? (uri x) (uri y))
       (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)
  (content-type #:init-keyword #:content-type #:getter content-type)
  (content #:init-keyword #:content #:getter content))

(define (all-links? elements)
  (match elements
    (() #t)
    (((? (cute is-a? <> <link>)) elements ...)
     (all-links? elements))
    (else #f)))

(define-method (initialize (page <loaded-page>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((etag #f)
    (links #f)
    (content-type #f)
    (content #f))
   (let do-initialize ((etag etag)
                       (links links)
                       (content-type content-type)
                       (content content))
     (match `(,etag ,links ,content-type ,content)
       (((or (? not etag)
             (? string? etag))
         (? all-links? links)
         (or (? symbol? content-type)
             ((? symbol? content-type) _ ...))
         (or (? string? content)
             (? bytevector? content)
             (? not content)))
        (slot-set! page 'etag etag)
        (slot-set! page 'links links)
        (slot-set! page 'content-type content-type)
        (slot-set! page 'content content))
       (else
        (scm-error 'wrong-type-arg "make <error-page>"
                   (G_ "the etag (#:etag) should be a string or #f, the links (#:links) should be a list of links, the content-type (#:content-type) should be a symbol or a list whose first item is a symbol, and the content (#:content) should be a string or a bytevector, or #f for responses without a content")
                   '()
                   (list etag links content-type content)))))))

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

(define-class <updated-page> (<loaded-page>)
  (desired-links #:init-keyword #:desired-links #:getter desired-links)
  (desired-content-type #:init-keyword #:desired-content-type #:getter desired-content-type)
  (desired-content #:init-keyword #:desired-content #:getter desired-content))

(define-method (initialize (page <updated-page>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((desired-links #f)
    (desired-content-type #f)
    (desired-content #f))
   (let do-initialize ((desired-links desired-links)
                       (desired-content-type desired-content-type)
                       (desired-content desired-content))
     (match `(,desired-links ,desired-content-type ,desired-content)
       (((? list? desired-links)
         (? symbol? desired-content-type)
         (or (? string? desired-content)
             (? bytevector? desired-content)))
        (slot-set! page 'desired-links desired-links)
        (slot-set! page 'desired-content-type desired-content-type)
        (slot-set! page 'desired-content desired-content))
       (else
        (scm-error 'wrong-type-arg "make <updated-page>"
                   (G_ "the desired links (#:desired-links) should be an alist from URI to alists, the desired content-type (#:desired-content-type) should be a symbol, and the desired content (#:desired-content) should be a string or a bytevector")
                   '()
                   (list desired-links desired-content-type desired-content)))))))

(define-method (equal? (x <updated-page>) (y <updated-page>))
  (and (equal? (uri x) (uri y))
       (equal? (etag x) (etag y))
       (equal? (links x) (links y))
       (equal? (content-type x) (content-type y))
       (equal? (content x) (content y))
       (equal? (desired-links x) (desired-links y))
       (equal? (desired-content-type x) (desired-content-type y))
       (equal? (desired-content x) (desired-content y))))

(define-method (edit-page (page <page>))
  page)

(define-method (edit-page (page <loaded-page>))
  (make <updated-page>
    #:uri (uri page)
    #:etag (etag page)
    #:links (links page)
    #:content-type (content-type page)
    #:content (content page)
    #:desired-links (links page)
    #:desired-content-type (content-type page)
    #:desired-content (content page)))

(define-method (edit-page (page <updated-page>))
  page)

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

(define-method (remove-link (page <page>) target key value)
  (let ((ret (edit-page page)))
    (when (is-a? ret <updated-page>)
      (let ((filtered
             (map (match-lambda
                    (((? (cute equal? <> target)) attributes ...)
                     `(,target
                       ,(filter
                         (match-lambda
                           ((the-key . the-value)
                            (and (equal? the-key key)
                                 (equal? the-value value))))
                         attributes)))
                    (other other))
                  (links ret))))
        (slot-set! ret 'desired-links
                   (filter (match-lambda
                             (((? uri?) ())
                              #f)
                             (else #t))
                           filtered))))
    ret))

(define-method (remove-link (state <application-state>) target key value)
  (let ((ret (shallow-clone state)))
    (slot-set! ret 'page (remove-link (page ret) target key value))
    ret))

(define-method (add-link (page <page>) target key value)
  (let ((ret (edit-page page)))
    (when (is-a? ret <updated-page>)
      (slot-set! ret 'desired-links
                 `((,target (,key . ,value))
                   ,@(desired-links page))))
    ret))

(define-method (add-link (state <application-state>) target key value)
  (let ((ret (shallow-clone state)))
    (slot-set! ret 'page (add-link (page ret) (string->uri target) key value))
    ret))

(define-method (set-page-uri (state <application-state>) page-uri)
  (let ((ret (shallow-clone state))
        (new-page (make <loading-page>
                    #:uri page-uri)))
    (slot-set! ret 'page new-page)
    (add-job
     ret
     (format #f (G_ "Loading ~a...") (uri->string (uri new-page)))
     (lambda ()
       (declare-link-header!)
       (let ((account (main-account state))
             (client (client state)))
         (parameterize ((client:client client))
           (receive (updated-account response response-body)
               (client:request account (uri new-page))
             (lambda (previous-state)
               (let ((ret (shallow-clone previous-state)))
                 ;; If the main client hasn’t changed, update it
                 (when (equal? (main-account previous-state) account)
                   (slot-set! ret 'main-account updated-account))
                 ;; If the page hasn’t changed, update it
                 (when (equal? (page previous-state)
                               new-page)
                   (slot-set! ret 'page
                              (if (eqv? (response-code response) 200)
                                  (make <loaded-page>
                                    #:uri (uri new-page)
                                    #:etag
                                    (match (response-etag response)
                                      ((value . #f) value)
                                      (else #f))
                                    #:links
                                    (response-links response)
                                    #:content-type
                                    (response-content-type response)
                                    #:content
                                    (or (false-if-exception (utf8->string response-body))
                                        response-body))
                                  (make <error-page>
                                    #:uri (uri new-page)
                                    #:code (response-code response)
                                    #:reason-phrase (response-reason-phrase response)))))
                 ret)))))))))

(define-method (change-content-type (state <application-state>) content-type)
  (let ((ret (shallow-clone state)))
    (slot-set!
     ret 'page
     (let ((p (edit-page (page ret))))
       (slot-set! p 'desired-content-type content-type)
       p))
    ret))

(define-method (change-content (state <application-state>) content)
  (let ((ret (shallow-clone state)))
    (slot-set!
     ret 'page
     (let ((p (edit-page (page ret))))
       (slot-set! p 'desired-content content)
       p))
    ret))

(define-method (discard-updates (page <page>))
  page)

(define-method (discard-updates (page <updated-page>))
  (make <loaded-page>
    #:uri (uri page)
    #:etag (etag page)
    #:links (links page)
    #:content-type (content-type page)
    #:content (content page)))
       
(define-method (discard-updates (state <application-state>))
  (let ((ret (shallow-clone state)))
    (slot-set! ret 'page (discard-updates (page state)))
    ret))

(define-method (commit-updates (state <application-state>))
  (let ((loading (shallow-clone state)))
    (slot-set! loading 'page
               (make <loading-page>
                 #:uri (uri (page state))))
    (if (is-a? (page state) <updated-page>)
        (add-job
         loading
         (format #f (G_ "Updating ~a (expected ETag ~a)")
                 (uri->string (uri (page state)))
                 (etag (page state)))
         (lambda ()
           (let ((account (main-account state))
                 (client (client state)))
             (parameterize ((client:client client))
               (receive (updated-account response response-body)
                   (client:request account (uri (page state))
                                   #:method 'PUT
                                   #:headers `(,@(let ((etag (etag (page state))))
                                                   (if etag
                                                       `((if-match . ((,etag . #f))))
                                                       '()))
                                               ,@(map
                                                  (lambda (link)
                                                    `(link . ,link))
                                                  (desired-links (page state)))
                                               (content-type . (,(desired-content-type (page state)))))
                                   #:body (desired-content (page state)))
                 (lambda (previous-state)
                   (let ((ret (shallow-clone previous-state)))
                     (when (equal? (main-account previous-state) account)
                       (slot-set! ret 'main-account updated-account))
                     (when (equal? (page previous-state)
                                   (page loading))
                       (slot-set! ret 'page
                                  (if (eqv? (response-code response) 200)
                                      (make <loaded-page>
                                        #:uri (uri (page state))
                                        #:etag (match (response-etag response)
                                                 ((etag . #f) etag)
                                                 (else #f))
                                        #:links (desired-links (page state))
                                        #:content-type (desired-content-type (page state))
                                        #:content (desired-content (page state)))
                                      (make <error-page>
                                        #:uri (uri (page state))
                                        #:code (response-code response)
                                        #:reason-phrase (response-reason-phrase response)))))
                     ret)))))))
        state)))

(define-method (delete-page (state <application-state>))
  (if (is-a? (page state) <page-with-uri>)
      (add-job
       state
       (format #f (G_ "Deleting ~a (expected ETag ~a)")
               (uri (page state))
               (and (is-a? (page state) <loaded-page>)
                    (etag (page state))))
       (lambda ()
         (let ((account (main-account state))
               (client (client state)))
           (parameterize ((client:client client))
             (receive (updated-account response response-body)
                 (client:request account (uri (page state))
                                 #:method 'DELETE
                                 #:headers `(,@(let ((etag (and (is-a? (page state) <loaded-page>)
                                                                (etag (page state)))))
                                                 (if etag
                                                     `((if-match . (,(etag (page state)) . #f)))
                                                     '()))))
               (lambda (previous-state)
                 (let ((ret (shallow-clone previous-state)))
                   (when (equal? (main-account previous-state) account)
                     (slot-set! ret 'main-account updated-account))
                   (when (equal? (page previous-state)
                                 (page state))
                     (slot-set! ret 'page
                                (make <new-page>)))
                   ret)))))))
      state))