;; 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 .
(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 client gui application-hooks)
#:use-module (webid-oidc client application)
#: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-state
))
(push-duplicate-handler! 'merge-generics)
(use-typelibs (("Gio" "2.0")))
(define goops:make
(@ (oop goops) make))
(define app:client
(@ (webid-oidc client application) client))
(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-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))))
(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 settings "subject")))
(issuer (empty-is-false (settings:get-string settings "issuer")))
(key-pair (empty-is-false (settings:get-string settings "key-pair")))
(id-token-header (empty-is-false (settings:get-string settings "id-token-header")))
(id-token (empty-is-false (settings:get-string settings "id-token")))
(access-token (empty-is-false (settings:get-string settings "access-token")))
(refresh-token (empty-is-false (settings:get-string 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
#:subject subject
#:issuer issuer
#:key-pair key-pair
#:id-token
(and id-token-header id-token
(goops:make
#: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))))
(call-with-values
(lambda ()
(let ((id (id-token account)))
(if id
(token->jwt id)
(values #f #f))))
(lambda (id-token-header id-token)
(settings:set-string? settings "id-token-header"
(if id-token-header
(stubs:scm->json-string id-token-header)
""))
(settings:set-string? settings "id-token"
(if id-token
(stubs:scm->json-string id-token)
""))))
(settings:set-string? settings "access-token" (or (access-token account) ""))
(settings:set-string? settings "refresh-token" (or (refresh-token account) ""))))
(define (get-main-account)
(read-account main-account-settings))
(define (set-main-account! account)
(save-account main-account-settings account))
(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)
((() . settings)
(do-save (list #f) settings))
((_ . ())
(fail (G_ "can only store 10 accounts")))
(((account accounts ...) . (setting settings ...))
(save-account setting account)
(do-save accounts settings))))))
(define last-application-state #f)
(define hook-enabled?
(make-parameter #t))
(connect client-settings change-event
(lambda _
(let ((the-client (get-client)))
(when (and last-application-state
(not (equal? the-client (client last-application-state))))
(set! last-application-state
(set-client last-application-state client))
(when (hook-enabled?)
(run-hook application-state-changed-hook last-application-state)))
#f)))
(define (run-accounts-changed-hook . _)
(let ((main (get-main-account))
(other (get-other-accounts)))
(when (and last-application-state
(or (not (equal? main (main-account last-application-state)))
(not (equal? other (other-accounts last-application-state)))))
(set! last-application-state
(set-accounts last-application-state
(if main
`(,main ,@other)
other)))
(when (hook-enabled?)
(run-hook application-state-changed-hook last-application-state)))
#f))
(connect main-account-settings change-event run-accounts-changed-hook)
(for-each
(lambda (settings)
(connect settings change-event run-accounts-changed-hook))
other-accounts-settings)
(add-hook! application-activated-hook
(lambda (app)
(set! last-application-state
(goops:make
#:main-account (get-main-account)
#:other-accounts (get-other-accounts)
#:client (get-client)))
(run-hook application-state-changed-hook last-application-state))
#t)
(define application-state
(match-lambda*
(() last-application-state)
((new-state)
(unless (equal? new-state last-application-state)
(parameterize ((hook-enabled? #f))
(set-client! (app:client new-state))
(set-main-account! (main-account new-state))
(set-other-accounts! (other-accounts new-state)))
(set! last-application-state new-state)
(run-hook application-state-changed-hook last-application-state)))))