gui: Add a client widget

1 files changed, 147 insertions, 0 deletions

diff --git a/src/scm/webid-oidc/client/gui/client-widget.scm b/src/scm/webid-oidc/client/gui/client-widget.scm
new file mode 100644
index 0000000..792b8f8
--- /dev/null
+++ b/src/scm/webid-oidc/client/gui/client-widget.scm
@@ -0,0 +1,147 @@
+;; 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 client-widget)
+  #:use-module (gi)
+  #:use-module (gi types)
+  #:use-module (gi util)
+  #:use-module (gi repository)
+  #: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 control)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-19)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc web-i18n)
+  #: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 config) #:prefix config:)
+  #:use-module (webid-oidc client)
+  #:use-module (webid-oidc client accounts)
+  #:use-module ((webid-oidc client gui settings) #:prefix settings:)
+  #:use-module (webid-oidc client gui application-hooks)
+  #:use-module (web uri)
+  #:use-module (web response)
+  #:use-module (rnrs bytevectors)
+  #:use-module (oop goops)
+  #:duplicates (merge-generics)
+  #:export
+  (
+   client-widget
+   ))
+
+(push-duplicate-handler! 'merge-generics)
+
+;; This avoids a crash when compiling the module
+(use-typelibs ("GdkPixbuf" "2.0")
+              ("Gtk" "3.0"))
+
+(define builder #f)
+(define client-widget #f)
+
+(define (build-client-widget app)
+  (unless client-widget
+    (set! builder
+          (builder:new-from-file (string-append config:uidir "/client-widget.glade")))
+    (set! client-widget
+          (builder:get-object builder "client_widget"))
+    (let ((client-id-entry
+           (builder:get-object builder "client_id_entry"))
+          (redirect-uri-entry
+           (builder:get-object builder "redirect_uri_entry"))
+          (key-pair-entry
+           (builder:get-object builder "key_pair_entry"))
+          (generate-key-pair-button
+           (builder:get-object builder "generate_key_pair_button"))
+          (undo-button
+           (builder:get-object builder "undo_button"))
+          (update-button
+           (builder:get-object builder "update_button")))
+      (define (current-edition)
+        ;; Return the client based on the edited fields
+        (let/ec return
+          (with-exception-handler
+              (lambda (exn)
+                ((@ (ice-9 format) format)
+                 (current-error-port)
+                 (G_ "The client cannot be constructed: ~a\n")
+                 (if (exception-with-message? exn)
+                     (exception-message exn)
+                     exn))
+                (return #f))
+            (lambda ()
+              ((@ (oop goops) make) <client>
+                #:client-id (entry:get-text client-id-entry)
+                #:redirect-uri (entry:get-text redirect-uri-entry)
+                #:key-pair
+                (jwk:jwk->key (stubs:json-string->scm (entry:get-text key-pair-entry))))))))
+      (define (on-entry-changed . _)
+        (let ((current-client (settings:client))
+              (edited (current-edition)))
+          (receive (can-undo? can-update?)
+              (cond
+               ((and edited (equal? edited current-client))
+                ;; The undo button is disabled and the update button too
+                (values #f #f))
+               (edited
+                ;; We have changed something and it’s valid
+                (values #t #t))
+               (else
+                ;; We have changed something, but it’s invalid
+                (values #t #f)))
+            (widget:set-sensitive undo-button can-undo?)
+            (widget:set-sensitive update-button can-update?))))
+      (define (set-client client)
+        (entry:set-text client-id-entry (uri->string (client-id client)))
+        (entry:set-text redirect-uri-entry (uri->string (redirect-uri client)))
+        (entry:set-text key-pair-entry
+                        (stubs:scm->json-string
+                         (jwk:key->jwk (key-pair client))))
+        (on-entry-changed))
+      ((@ (gi) connect) client-id-entry activate on-entry-changed)
+      ((@ (gi) connect) redirect-uri-entry activate on-entry-changed)
+      ((@ (gi) connect) key-pair-entry activate on-entry-changed)
+      ((@ (gi) connect)
+       generate-key-pair-button clicked
+       (lambda _
+         (entry:set-text key-pair-entry
+                         (stubs:scm->json-string
+                          (jwk:key->jwk
+                           (jwk:generate-key #:n-size 2048))))
+         (on-entry-changed)))
+      ((@ (gi) connect) undo-button clicked
+       (lambda _
+         (set-client (settings:client))
+         (on-entry-changed)))
+      ((@ (gi) connect) update-button clicked
+       (lambda _
+         (settings:client (current-edition))
+         (widget:set-sensitive undo-button #f)
+         (widget:set-sensitive update-button #f)))
+      (set-client (settings:client))
+      (add-hook! settings:client-changed-hook
+                 (lambda (c)
+                   (unless (widget:get-sensitive? undo-button)
+                     ;; If we were doing an edition, ignore
+                     (set-client c)))))))
+
+(add-hook! application-activated-hook build-client-widget)