;; 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

   client-changed-hook
   accounts-changed-hook
   ))

(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))))

(define client-changed-hook
  (make-hook 1))

(define accounts-changed-hook
  (make-hook 2))

(connect client-settings change-event
         (lambda _
           (run-hook client-changed-hook (client))
           #f))

(define (run-accounts-changed-hook . _)
  (run-hook accounts-changed-hook
            (main-account)
            (other-accounts))
  #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)