summaryrefslogtreecommitdiff
path: root/src/scm/webid-oidc/client/gui/clock.scm
blob: 87d6b48de37fb012869a88b61a7a0019b97e19c5 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
;; 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 clock)
  #:use-module (gi)
  #:use-module (gi types)
  #:use-module (gi util)
  #:use-module (ice-9 atomic)
  #:use-module (webid-oidc client gui application-hooks)
  #:use-module (webid-oidc client application)
  #:use-module ((webid-oidc client gui settings) #:prefix settings:)
  #:declarative? #t
  #:duplicates (merge-generics)
  #:export (wait))

(use-typelibs ("GLib" "2.0"))

(define pending-ops (make-atomic-box '()))

(define (wait f)
  (let ((old (atomic-box-ref pending-ops)))
    (unless (eq? old (atomic-box-compare-and-swap! pending-ops old `(,f ,@old)))
      (wait f))))

(define (run . _)
  (let ((old (atomic-box-ref pending-ops)))
    (if (eq? old (atomic-box-compare-and-swap! pending-ops old '()))
        (begin
          (for-each (lambda (f) (f)) (reverse old))
          (settings:application-state
           (join (settings:application-state)))
          #t)
        (run))))

(add-hook! application-activated-hook
           (lambda (app)
             (timeout-add 0 200 run)))