;; 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 gui authorizations-widget)
  #:use-module (gi)
  #:use-module (gi types)
  #:use-module (gi util)
  #: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 pretty-print)
  #:use-module (ice-9 atomic)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (webid-oidc errors)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module ((webid-oidc config) #:prefix config:)
  #:use-module (webid-oidc web-i18n)
  #:use-module (webid-oidc client client)
  #:use-module (webid-oidc client accounts)
  #:use-module (webid-oidc client gui authorization-prompt)
  #:use-module ((webid-oidc client gui settings) #:prefix settings:)
  #:use-module ((webid-oidc client gui clock) #:prefix clock:)
  #:use-module (webid-oidc client gui application-hooks)
  #:use-module (webid-oidc jwk)
  #:use-module (webid-oidc oidc-id-token)
  #:use-module (web uri)
  #:use-module (web response)
  #:use-module (rnrs bytevectors)
  #:use-module (oop goops)
  #:declarative? #t
  #:duplicates (merge-generics)
  #:export
  (
   authorizations-widget
   use-authorizations-widget
   ))

(push-duplicate-handler! 'merge-generics)

;; This avoids a crash when compiling the module
(use-typelibs ("GdkPixbuf" "2.0")
              ("Gtk" "3.0"))

(define authorizations-widget #f)
(define by-uri (make-hash-table))

(define authorizations-widget #f)

;; Since authorizations may be requested by any threads, they are
;; collected here and a timer updates the GUI every so often.
(define pending-authorizations
  (make-atomic-box '()))

(define (update-ui)
  (let ((authz (atomic-box-ref pending-authorizations)))
    (let ((confirmed (atomic-box-compare-and-swap! pending-authorizations authz '())))
      (if (eq? authz confirmed)
          (let add-authorization ((authz authz))
            (match authz
              (() ;; done
               #t)
              (((reason uri continuation) authz ...)
               (let ((value (uri->string uri)))
                 (match (or (hash-ref by-uri value)
                            (receive (builder widget handle)
                                ((@ (webid-oidc client gui authorization-prompt)
                                    make-authorization-prompt) uri)
                              (let ((ret `(,builder ,widget ,handle)))
                                (hash-set! by-uri value ret)
                                (box:pack-start authorizations-widget widget #t #t 0)
                                ret)))
                   ((_ widget handle)
                    ;; Put it on top
                    (container:remove authorizations-widget widget)
                    (box:pack-start authorizations-widget widget #t #t 0)
                    ;; Add (reason, continuation) to the
                    ;; existing or created widget
                    (handle reason
                            (lambda (code)
                              ;; When the button is
                              ;; clicked, first remove
                              ;; the widget if it still
                              ;; exists
                              (when (hash-ref by-uri value)
                                (hash-remove! by-uri value)
                                (container:remove authorizations-widget widget))
                              ((@ (ice-9 threads) call-with-new-thread)
                               (lambda ()
                                 ;; In case the
                                 ;; continuation expects
                                 ;; further authorizations:
                                 (use-authorizations-widget
                                  (lambda ()
                                    (continuation code)))))))))))))
          ;; Else, retry
          (update-ui)))))

(define (use-authorizations-widget f)
  (let ((prompt (make-prompt-tag)))
    (call-with-prompt prompt
      (lambda ()
        (parameterize
            ((authorization-process
              (lambda* (uri #:key reason)
                (abort-to-prompt
                 prompt
                 (lambda (continuation)
                   (let save ((other (atomic-box-ref pending-authorizations)))
                     (let ((confirmed
                            (atomic-box-compare-and-swap!
                             pending-authorizations
                             other
                             `((,reason ,uri ,continuation) ,@other))))
                       (unless (eq? confirmed other)
                         (save (atomic-box-ref pending-authorizations))))))))))
          (f)))
      (lambda (continuation handler)
        (handler continuation)))))

(define (update-ui-next)
  (update-ui)
  (clock:wait
   (lambda ()
     (update-ui-next))))

(define (build-widget app)
  (unless authorizations-widget
    (set! authorizations-widget (box:new (symbol->orientation 'vertical) 8))
    (clock:wait
     (lambda ()
       (update-ui-next)))))

(add-hook! application-activated-hook build-widget)