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

(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 <account>
             #:subject subject
             #:issuer issuer
             #:key-pair key-pair
             #:id-token
             (and id-token-header 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))))
    (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 the-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 <application-state>
                 #: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)))))