gui: Add a client widget

6 files changed, 286 insertions, 19 deletions

diff --git a/src/scm/webid-oidc/client/gui.scm b/src/scm/webid-oidc/client/gui.scm
index 45910e3..be557bd 100644
--- a/src/scm/webid-oidc/client/gui.scm
+++ b/src/scm/webid-oidc/client/gui.scm
@@ -36,6 +36,7 @@
   #: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) #:prefix app:)
   #:use-module (web uri)
   #:use-module (web response)
   #:use-module (rnrs bytevectors)
@@ -57,27 +58,13 @@
 
 (add-hook! settings:client-changed-hook
            (lambda (client)
-             (format #t (G_ "The client changed: it is now ~a.\n") client)))
+             (format #t (G_ "The client changed: it is now ~a.\n") client)
+             ((@ (webid-oidc client) client) client)))
 
 (add-hook! settings:accounts-changed-hook
            (lambda (main other)
              (format #t (G_ "The accounts changed: the main account is ~a, and the others are ~a.\n")
                      main other)))
 
-(define (print-hello button)
-  (format #t (G_ "Hello, world!\n")))
-
-(define (on-activate application)
-  (let ((window (make <GtkApplicationWindow>
-                  #:application application))
-        (button (make <GtkButton> #:label (G_ "Hello, world!"))))
-    (connect button clicked print-hello)
-    (add window button)
-    (show-all window)))
-
 (define (main)
-  (let ((app (application:new
-              "eu.planete_kraus.Disfluid"
-              (list->application-flags '(flags-none)))))
-    (connect app activate on-activate)
-    (run app (command-line))))
+  (run app:application (command-line)))
diff --git a/src/scm/webid-oidc/client/gui/Makefile.am b/src/scm/webid-oidc/client/gui/Makefile.am
index 86d6dd3..64b1870 100644
--- a/src/scm/webid-oidc/client/gui/Makefile.am
+++ b/src/scm/webid-oidc/client/gui/Makefile.am
@@ -15,7 +15,13 @@
 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
 
 dist_guiclientwebidoidcmod_DATA += \
-  %reldir%/settings.scm
+  %reldir%/settings.scm \
+  %reldir%/client-widget.scm \
+  %reldir%/application-hooks.scm \
+  %reldir%/application.scm
 
 guiclientwebidoidcgo_DATA += \
-  %reldir%/settings.go
+  %reldir%/settings.go \
+  %reldir%/client-widget.go \
+  %reldir%/application-hooks.go \
+  %reldir%/application.go
diff --git a/src/scm/webid-oidc/client/gui/application-hooks.scm b/src/scm/webid-oidc/client/gui/application-hooks.scm
new file mode 100644
index 0000000..0d51599
--- /dev/null
+++ b/src/scm/webid-oidc/client/gui/application-hooks.scm
@@ -0,0 +1,46 @@
+;; 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 application-hooks)
+  #: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 (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 web-i18n)
+  #:use-module (webid-oidc client client)
+  #:use-module (webid-oidc client accounts)
+  #: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
+  (
+   application-activated-hook
+   ))
+
+(define application-activated-hook
+  (make-hook 1))
diff --git a/src/scm/webid-oidc/client/gui/application.scm b/src/scm/webid-oidc/client/gui/application.scm
new file mode 100644
index 0000000..361e12d
--- /dev/null
+++ b/src/scm/webid-oidc/client/gui/application.scm
@@ -0,0 +1,72 @@
+;; 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 application)
+  #: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 (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 dpop-proof) #:prefix dpop:)
+  #: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 client-widget) #:prefix client:)
+  #:use-module (webid-oidc client gui application-hooks)
+  #:use-module (web uri)
+  #:use-module (web response)
+  #:use-module (rnrs bytevectors)
+  #:use-module (oop goops)
+  #:declarative? #t
+  #:export
+  (
+   application
+   ))
+
+(push-duplicate-handler! 'merge-generics)
+
+;; This avoids a crash when compiling the module
+(use-typelibs ("GdkPixbuf" "2.0"))
+
+(use-typelibs (("Gio" "2.0") #:renamer (protect 'application:new))
+              ("Gtk" "3.0"))
+
+(define application
+  (application:new
+   "eu.planete_kraus.Disfluid"
+   (list->application-flags '(flags-none))))
+
+(define (on-activate application)
+  (run-hook application-activated-hook application)
+  (let ((window (make <GtkApplicationWindow>
+                  #:application application))
+        (widget client:client-widget))
+    (add window widget)
+    (show-all window)))
+
+(connect application activate on-activate)
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)
diff --git a/src/scm/webid-oidc/client/gui/settings.scm b/src/scm/webid-oidc/client/gui/settings.scm
index 57ebbfb..8f97b2e 100644
--- a/src/scm/webid-oidc/client/gui/settings.scm
+++ b/src/scm/webid-oidc/client/gui/settings.scm
@@ -32,6 +32,7 @@
   #:use-module (webid-oidc web-i18n)
   #:use-module (webid-oidc client client)
   #:use-module (webid-oidc client accounts)
+  #:use-module (webid-oidc client gui application-hooks)
   #:use-module (webid-oidc jwk)
   #:use-module (webid-oidc oidc-id-token)
   #:use-module (web uri)
@@ -234,3 +235,11 @@
  (lambda (settings)
    (connect settings change-event run-accounts-changed-hook))
  other-accounts-settings)
+
+(add-hook! application-activated-hook
+           (lambda (app)
+             (run-hook client-changed-hook (client))
+             (run-hook accounts-changed-hook
+                       (main-account)
+                       (other-accounts)))
+           #t)