gui: Bind the settings to scheme

5 files changed, 252 insertions, 4 deletions

diff --git a/src/Makefile.am b/src/Makefile.am
index 38e458d..eedfe4a 100644
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -39,6 +39,9 @@ resourceserverwebidoidcgodir = $(serverwebidoidcgodir)/resource
 clientwebidoidcmoddir = $(webidoidcmoddir)/client
 clientwebidoidcgodir = $(webidoidcgodir)/client
 
+guiclientwebidoidcmoddir = $(clientwebidoidcmoddir)/gui
+guiclientwebidoidcgodir = $(clientwebidoidcgodir)/gui
+
 dist_mod_DATA =
 mod_DATA =
 go_DATA =
@@ -56,8 +59,11 @@ clientwebidoidcgo_DATA =
 dist_resourceserverwebidoidcmod_DATA =
 resourceserverwebidoidcgo_DATA =
 
-install_go_targets = install-webidoidcgoDATA install-serverwebidoidcgoDATA install-resourceserverwebidoidcgoDATA
-install_mod_targets = install-webidoidcmodDATA install-dist_webidoidcmodDATA install-dist_serverwebidoidcmodDATA install-dist_resourceserverwebidoidcmodDATA
+dist_guiclientwebidoidcmod_DATA =
+guiclientwebidoidcgo_DATA =
+
+install_go_targets = install-webidoidcgoDATA install-serverwebidoidcgoDATA install-resourceserverwebidoidcgoDATA install-clientwebidoidcgoDATA install-guiclientwebidoidcgoDATA
+install_mod_targets = install-webidoidcmodDATA install-dist_webidoidcmodDATA install-dist_serverwebidoidcmodDATA install-dist_resourceserverwebidoidcmodDATA install-dist_clientwebidoidcmodDATA install-dist_guiclientwebidoidcmodDATA
 
 include %reldir%/base64/Makefile.am
 include %reldir%/random/Makefile.am
@@ -69,14 +75,22 @@ include %reldir%/inst/Makefile.am
 include %reldir%/scm/Makefile.am
 
 CLEANFILES += $(go_DATA) $(webidoidcgo_DATA) $(mod_DATA) $(webidoidcmod_DATA) \
-  $(serverwebidoidcgo_DATA) $(clientwebidoidcgo_DATA) $(resourceserverwebidoidcgo_DATA)
+  $(serverwebidoidcgo_DATA) $(clientwebidoidcgo_DATA) $(resourceserverwebidoidcgo_DATA) \
+  $(guiclientwebidoidcgo_DATA)
+
+.PHONY: clean-xdg-extra-data-dir
+
+clean-local: clean-xdg-extra-data-dir
+
+clean-xdg-extra-data-dir:
+	rm -rf xdg-extra-data-dir
 
 %canon_reldir%_libwebidoidc_la_SOURCES = %reldir%/gettext.h %reldir%/libwebidoidc.c %reldir%/utilities.h
 %canon_reldir%_libwebidoidc_la_LIBADD = $(noinst_LTLIBRARIES) $(GUILE_LIBS) $(NETTLE_LIBS)
 
 INDENTED += $(%canon_reldir%_libwebidoidc_la_SOURCES)
 
-$(go_DATA) $(webidoidcgo_DATA) $(serverwebidoidcgo_DATA) $(clientwebidoidcgo_DATA) $(resourceserverwebidoidcgo_DATA): %reldir%/libwebidoidc.la
+$(go_DATA) $(webidoidcgo_DATA) $(serverwebidoidcgo_DATA) $(clientwebidoidcgo_DATA) $(resourceserverwebidoidcgo_DATA) $(guiclientwebidoidcgo_DATA): %reldir%/libwebidoidc.la xdg-extra-data-dir/glib-2.0/schemas/gschemas.compiled xdg-extra-data-dir/glib-2.0/schemas/eu.planete_kraus.Disfluid.gschema.xml
 
 SUFFIXES += .c .x .scm .go
 .c.x:
diff --git a/src/scm/webid-oidc/client/Makefile.am b/src/scm/webid-oidc/client/Makefile.am
index bf9feb7..8ecf7d5 100644
--- a/src/scm/webid-oidc/client/Makefile.am
+++ b/src/scm/webid-oidc/client/Makefile.am
@@ -25,3 +25,5 @@ clientwebidoidcgo_DATA += \
   %reldir%/client.go \
   %reldir%/application.go \
   %reldir%/gui.go
+
+include %reldir%/gui/Makefile.am
diff --git a/src/scm/webid-oidc/client/gui.scm b/src/scm/webid-oidc/client/gui.scm
index 97e9d0e..c446fc7 100644
--- a/src/scm/webid-oidc/client/gui.scm
+++ b/src/scm/webid-oidc/client/gui.scm
@@ -34,6 +34,7 @@
   #: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 gui settings) #:prefix settings)
   #:use-module (web uri)
   #:use-module (web response)
   #:use-module (rnrs bytevectors)
diff --git a/src/scm/webid-oidc/client/gui/Makefile.am b/src/scm/webid-oidc/client/gui/Makefile.am
new file mode 100644
index 0000000..86d6dd3
--- /dev/null
+++ b/src/scm/webid-oidc/client/gui/Makefile.am
@@ -0,0 +1,21 @@
+# 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/>.
+
+dist_guiclientwebidoidcmod_DATA += \
+  %reldir%/settings.scm
+
+guiclientwebidoidcgo_DATA += \
+  %reldir%/settings.go
diff --git a/src/scm/webid-oidc/client/gui/settings.scm b/src/scm/webid-oidc/client/gui/settings.scm
new file mode 100644
index 0000000..5ce62b0
--- /dev/null
+++ b/src/scm/webid-oidc/client/gui/settings.scm
@@ -0,0 +1,210 @@
+;; 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 settings)
+  #: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 (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
+  (
+   client
+   main-account
+   other-accounts
+   ))
+
+(push-duplicate-handler! 'merge-generics)
+
+(use-typelibs (("Gio" "2.0")))
+
+(define goops:make
+  (@ (oop goops) make))
+
+(define root-settings
+  (settings:new "eu.planete_kraus.Disfluid"))
+
+(define client-settings
+  (settings:get-child root-settings "client"))
+
+(define main-account-settings
+  (settings:get-child root-settings "main-account"))
+
+;; FIXME: when https://gitlab.gnome.org/GNOME/glib/-/issues/993 is
+;; solved, use relocatable schemas
+(define other-accounts-settings
+  (map (lambda (id)
+         (settings:get-child root-settings (format #f "other-account-~a" id)))
+       '(1 2 3 4 5 6 7 8 9 10)))
+
+(define (list-other-accounts-settings)
+  (let filter ((children (vector->list (settings:list-children root-settings)))
+               (settings '()))
+    (match children
+      (()
+       (reverse settingns))
+      (((or "client" "main-account")
+        children ...)
+       (filter children settings))
+      (((? (cute string-prefix? "account-" <>) name) children ...)
+       (filter children `(,(settings:get-child root-settings name) ,@settings))))))
+
+(define (get-client)
+  (let ((client-id (string->uri (settings:get-string client-settings "client-id")))
+        (key-pair-string (settings:get-string client-settings "key-pair"))
+        (redirect-uri (string->uri (settings:get-string client-settings "redirect-uri"))))
+    (let ((key-pair
+           (if (equal? key-pair-string "")
+               (generate-key #:n-size 2048)
+               (jwk->key (stubs:json-string->scm key-pair-string)))))
+      (goops:make <client>
+        #:client-id client-id
+        #:key-pair key-pair
+        #:redirect-uri redirect-uri))))
+
+(define (set-client! client)
+  (let ((saved (get-client)))
+    (unless (equal? client saved)
+      (settings:set-string? client-settings "client-id"
+                           (uri->string (client-id client)))
+      (settings:set-string? client-settings "key-pair"
+                           (stubs:scm->json-string (key->jwk (key-pair client))))
+      (settings:set-string? client-settings "redirect-uri"
+                           (uri->string (redirect-uri client)))
+      (settings:apply client-settings))))
+
+(define client
+  (match-lambda*
+    (() (get-client))
+    ((value) (set-client! value))))
+
+(unless (equal? (get-client) (get-client))
+  ;; The key is generated each time, fix it
+  (set-client! (get-client)))
+
+(define empty-is-false
+  (match-lambda
+    ("" #f)
+    (str str)))
+
+(define (read-account settings)
+  (let ((subject (empty-is-false (settings:get-string main-account-settings "subject")))
+        (issuer (empty-is-false (settings:get-string main-account-settings "issuer")))
+        (key-pair (empty-is-false (settings:get-string main-account-settings "key-pair")))
+        (id-token-header (empty-is-false (settings:get-string main-account-settings "id-token-header")))
+        (id-token (empty-is-false (settings:get-string main-account-settings "id-token")))
+        (access-token (empty-is-false (settings:get-string main-account-settings "access-token")))
+        (refresh-token (empty-is-false (settings:get-string main-account-settings "refresh-token"))))
+    (and subject issuer key-pair
+         (let ((subject (string->uri subject))
+               (issuer (string->uri issuer))
+               (key-pair (jwk->key (stubs:json-string->scm key-pair)))
+               (id-token-header (and id-token-header
+                                     (stubs:json-string->scm id-token-header)))
+               (id-token (and id-token
+                              (stubs:json-string->scm id-token))))
+           (goops:make <account>
+             #:subject subject
+             #:issuer issuer
+             #:key-pair key-pair
+             #:id-token
+             (goops:make <id-token>
+               #:jwt-header id-token-header
+               #:jwt-payload id-token)
+             #:access-token access-token
+             #:refresh-token refresh-token)))))
+
+(define (clear-account settings)
+  (settings:set-string? settings "subject" "")
+  (settings:set-string? settings "issuer" "")
+  (settings:set-string? settings "key-pair" "")
+  (settings:set-string? settings "id-token-header" "")
+  (settings:set-string? settings "id-token" "")
+  (settings:set-string? settings "access-token" "")
+  (settings:set-string? settings "refresh-token" ""))
+
+(define (save-account settings account)
+  (clear-account settings)
+  (when (and account (not (equal? (read-account settings) account)))
+    (settings:set-string? settings "subject" (uri->string (subject account)))
+    (settings:set-string? settings "issuer" (uri->string (issuer account)))
+    (settings:set-string? settings "key-pair"
+                         (stubs:scm->json-string (key->jwk (key-pair account))))
+    (when (id-token account)
+      (receive (id-token-header id-token)
+          (token->jwt (id-token account))
+        (settings:set-string? settings "id-token-header"
+                             (stubs:scm->json-string id-token-header))
+        (settings:set-string? settings "id-token"
+                             (stubs:scm->json-string id-token))))
+    (when (access-token account)
+      (settings:set-string? settings "access-token" (access-token account)))
+    (when (refresh-token account)
+      (settings:set-string? settings "refresh-token" (refresh-token account)))))
+
+(define (get-main-account)
+  (read-account main-account-settings))
+
+(define (set-main-account! account)
+  (save-account main-account-settings account))
+
+(define main-account
+  (match-lambda*
+    (() (get-main-account))
+    ((value) (set-main-account! value))))
+
+(define (get-other-accounts)
+  (filter (lambda (x) x)
+          (map read-account other-accounts-settings)))
+
+(define (set-other-accounts! accounts)
+  (when (not (equal? accounts (get-other-accounts)))
+    (let do-save ((accounts accounts)
+                  (settings other-accounts-settings))
+      (match `(,accounts . ,settings)
+        ((() . ()) #t)
+        ((() . (hd tl ...))
+         (do-save (list #f) tl))
+        ((_ . ())
+         (fail (G_ "can only store 10 accounts")))
+        (((account accounts ...) . (setting settings ...))
+         (save-account setting account)
+         (do-save accounts tl))))))
+
+(define other-accounts
+  (match-lambda*
+    (() (get-other-accounts))
+    ((value) (set-other-accounts! value))))