lib/guile/dolcon/util.scm

   1 (define-module (dolcon util))
   2 (use-modules (dolcon ui))
   3
   4 (define fnetnodes '())
   5 (define loop-procs '())
   6 (define fn-procs '())
   7
   8 (define-public dc-fn-update
   9   (lambda ()
  10     (set! fnetnodes
  11           (let ((resp (dc-ecmd "lsnodes")) (er #f))
  12             (if (and resp (begin (set! er (dc-extract resp)) er) (= (cdr (assq 'code er)) 200))
  13                 (map (lambda (o)
  14                        (apply (lambda (id net name users state uid)
  15                                 (cons id
  16                                       (list (cons 'id id)
  17                                             (cons 'net net)
  18                                             (cons 'name name)
  19                                             (cons 'users users)
  20                                             (cons 'state (list-ref '(syn hs est dead) state))
  21                                             (cons 'uid uid))))
  22                               o))
  23                      (dc-intall resp))
  24                 '())))
  25     fnetnodes))
  26
  27 (define-public dc-fn-getattrib
  28   (lambda (id attrib)
  29     (if (not (assq id fnetnodes))
  30         (dc-fn-update))
  31     (let ((aform (assq id fnetnodes)))
  32       (if aform
  33           (cdr (assq attrib (cdr aform)))
  34           #f))))
  35
  36 (define-public dc-fn-getname
  37   (lambda (id)
  38     (dc-fn-getattrib id 'name)))
  39
  40 (define-public dc-getfnetnodes
  41   (lambda ()
  42     (map (lambda (o) (car o))
  43          fnetnodes)))
  44
  45 (define fn-updattr
  46   (lambda (id attr val)
  47     (let ((aform (assq id fnetnodes)))
  48       (if aform
  49           (set-cdr! (assq attr (cdr aform)) val)
  50           #f))))
  51
  52 (define-public dc-fnproc-reg
  53   (lambda (event proc)
  54     (set! fn-procs (cons (list event proc)
  55                          fn-procs))))
  56
  57 (define-public dc-handle-fn
  58   (lambda ()
  59     (dc-fn-update)
  60     (let* ((notify (lambda (event data) (for-each (lambda (o) (if (eq? event (car o)) ((cadr o) data))) fn-procs)))
  61            (ua (lambda (r a) (let* ((ires (dc-intresp r))
  62                                     (hubform (assq (car ires) fnetnodes)))
  63                                (if hubform
  64                                    (begin (fn-updattr (car ires) a (cadr ires))
  65                                           (notify a (cdr (assq (car ires) fnetnodes)))))))))
  66       (dc-loop-reg ".notify" 601 (lambda (r er) (let* ((ires (dc-intresp r))
  67                                                        (hubform (assq (car ires) fnetnodes)))
  68                                                   (if hubform
  69                                                       (begin (fn-updattr (car ires) 'state (list-ref '(syn hs est dead) (cadr ires)))
  70                                                              (notify 'state (cdr hubform)))))))
  71       (dc-loop-reg ".notify" 602 (lambda (r er) (ua r 'name)))
  72       (dc-loop-reg ".notify" 605 (lambda (r er) (ua r 'users)))
  73       (dc-loop-reg ".notify" 604 (lambda (r er)
  74                                    (let* ((ires (dc-intresp r))
  75                                           (new (list (cons 'id (car ires))
  76                                                      (cons 'net (cadr ires))
  77                                                      (cons 'name "")
  78                                                      (cons 'users 0)
  79                                                      (cons 'state 'syn))))
  80                                      (set! fnetnodes
  81                                            (cons (cons (car ires) new)
  82                                                  fnetnodes))
  83                                      (notify 'creat new))))
  84       (dc-loop-reg ".notify" 603 (lambda (r er)
  85                                    (let* ((ires (dc-intresp r)) (nform (assq (car ires) fnetnodes)))
  86                                      (notify 'dstr (cdr nform))
  87                                      (set! fnetnodes (delq nform fnetnodes))))))))
  88
  89 (define-public dc-loop-reg
  90   (lambda (cmd code proc)
  91     (set! loop-procs (cons (cons (cons cmd code) proc)
  92                            loop-procs))))
  93
  94 (define-public dc-loop
  95   (lambda ()
  96     (while #t
  97            (dc-select 10000)
  98            (while (let ((resp (dc-getresp)))
  99                     (if resp
 100                         (let* ((er (dc-extract resp)) (code (cdr (assq 'code er))) (cmd (cdr (assq 'cmd er))))
 101                           (for-each
 102                            (lambda (o)
 103                              (if (and (or (not (caar o)) (equal? cmd (caar o)))
 104                                       (or (not (cdar o)) (equal? code (cdar o))))
 105                                  ((cdr o) resp er)))
 106                            loop-procs))
 107                         #f))
 108                   #f)
 109            (for-each (lambda (o)
 110                        (if (equal? (caar o) ".periodic")
 111                            ((cdr o))))
 112                      loop-procs))))