diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-26 18:49:03 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-01 12:32:20 +0200 |
commit | 92eb131fe69e2ffa81fb5207a9ce160f29b60a19 (patch) | |
tree | 979a0cd12b231c78c85e8f56b091d9c0e436bf53 /src | |
parent | e2fea447f29d276f025d99df638437ab7df89441 (diff) |
gui: Bind the settings to scheme
Diffstat (limited to 'src')
-rw-r--r-- | src/Makefile.am | 22 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/Makefile.am | 2 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/gui.scm | 1 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/gui/Makefile.am | 21 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/gui/settings.scm | 210 |
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)))) |