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                                                   (fn-updattr (car ires) 'state (list-ref '(syn hs est dead) (cadr ires)))
  68                                                   (notify 'state (cdr (assq (car ires) fnetnodes))))))
  69       (dc-loop-reg ".notify" 602 (lambda (r er) (ua r 'name)))
  70       (dc-loop-reg ".notify" 605 (lambda (r er) (ua r 'users)))
  71       (dc-loop-reg ".notify" 604 (lambda (r er)
  72                                    (let* ((ires (dc-intresp r))
  73                                           (new (list (cons 'id (car ires))
  74                                                      (cons 'net (cadr ires))
  75                                                      (cons 'name "")
  76                                                      (cons 'users 0)
  77                                                      (cons 'state 'syn))))
  78                                      (set! fnetnodes
  79                                            (cons (cons (car ires) new)
  80                                                  fnetnodes))
  81                                      (notify 'creat new))))
  82       (dc-loop-reg ".notify" 603 (lambda (r er)
  83                                    (let* ((ires (dc-intresp r)) (nform (assq (car ires) fnetnodes)))
  84                                      (notify 'dstr (cdr nform))
  85                                      (set! fnetnodes (delq nform fnetnodes))))))))
  86
  87 (define-public dc-loop-reg
  88   (lambda (cmd code proc)
  89     (set! loop-procs (cons (cons (cons cmd code) proc)
  90                            loop-procs))))
  91
  92 (define-public dc-loop
  93   (lambda ()
  94     (while #t
  95            (dc-select 10000)
  96            (while (let ((resp (dc-getresp)))
  97                     (if resp
  98                         (let* ((er (dc-extract resp)) (code (cdr (assq 'code er))) (cmd (cdr (assq 'cmd er))))
  99                           (for-each
 100                            (lambda (o)
 101                              (if (and (or (not (caar o)) (equal? cmd (caar o)))
 102                                       (or (not (cdar o)) (equal? code (cdar o))))
 103                                  ((cdr o) resp er)))
 104                            loop-procs))
 105                         #f))
 106                   #f)
 107            (for-each (lambda (o)
 108                        (if (equal? (caar o) ".periodic")
 109                            ((cdr o))))
 110                      loop-procs))))