lib/guile/dolcon/util.scm

   1 ;  Dolda Connect - Modular multiuser Direct Connect-style client
   2 ;  Copyright (C) 2007 Fredrik Tolf <fredrik@dolda2000.com>
   3 ;
   4 ;  This program is free software; you can redistribute it and/or modify
   5 ;  it under the terms of the GNU General Public License as published by
   6 ;  the Free Software Foundation; either version 2 of the License, or
   7 ;  (at your option) any later version.
   8 ;
   9 ;  This program is distributed in the hope that it will be useful,
  10 ;  but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;  GNU General Public License for more details.
  13 ;
  14 ;  You should have received a copy of the GNU General Public License
  15 ;  along with this program; if not, write to the Free Software
  16 ;  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 (define-module (dolcon util))
  19 (use-modules (dolcon ui))
  20
  21 (define fnetnodes '())
  22 (define loop-procs '())
  23 (define fn-procs '())
  24
  25 (define-public dc-fn-update
  26   (lambda ()
  27     (set! fnetnodes
  28           (let ((resp (dc-ecmd "lsnodes")) (er #f))
  29             (if (and resp (begin (set! er (dc-extract resp)) er) (= (cdr (assq 'code er)) 200))
  30                 (map (lambda (o)
  31                        (apply (lambda (id net name users state uid)
  32                                 (cons id
  33                                       (list (cons 'id id)
  34                                             (cons 'net net)
  35                                             (cons 'name name)
  36                                             (cons 'users users)
  37                                             (cons 'state (list-ref '(syn hs est dead) state))
  38                                             (cons 'uid uid))))
  39                               o))
  40                      (dc-intall resp))
  41                 '())))
  42     fnetnodes))
  43
  44 (define-public dc-fn-getattrib
  45   (lambda (id attrib)
  46     (if (not (assq id fnetnodes))
  47         (dc-fn-update))
  48     (let ((aform (assq id fnetnodes)))
  49       (if aform
  50           (cdr (assq attrib (cdr aform)))
  51           #f))))
  52
  53 (define-public dc-fn-getname
  54   (lambda (id)
  55     (dc-fn-getattrib id 'name)))
  56
  57 (define-public dc-getfnetnodes
  58   (lambda ()
  59     (map (lambda (o) (car o))
  60          fnetnodes)))
  61
  62 (define fn-updattr
  63   (lambda (id attr val)
  64     (let ((aform (assq id fnetnodes)))
  65       (if aform
  66           (set-cdr! (assq attr (cdr aform)) val)
  67           #f))))
  68
  69 (define-public dc-fnproc-reg
  70   (lambda (event proc)
  71     (set! fn-procs (cons (list event proc)
  72                          fn-procs))))
  73
  74 (define-public dc-handle-fn
  75   (lambda ()
  76     (dc-fn-update)
  77     (let* ((notify (lambda (event data) (for-each (lambda (o) (if (eq? event (car o)) ((cadr o) data))) fn-procs)))
  78            (ua (lambda (r a) (let* ((ires (dc-intresp r))
  79                                     (hubform (assq (car ires) fnetnodes)))
  80                                (if hubform
  81                                    (begin (fn-updattr (car ires) a (cadr ires))
  82                                           (notify a (cdr (assq (car ires) fnetnodes)))))))))
  83       (dc-loop-reg ".notify" 601 (lambda (r er) (let* ((ires (dc-intresp r))
  84                                                        (hubform (assq (car ires) fnetnodes)))
  85                                                   (if hubform
  86                                                       (begin (fn-updattr (car ires) 'state (list-ref '(syn hs est dead) (cadr ires)))
  87                                                              (notify 'state (cdr hubform)))))))
  88       (dc-loop-reg ".notify" 602 (lambda (r er) (ua r 'name)))
  89       (dc-loop-reg ".notify" 605 (lambda (r er) (ua r 'users)))
  90       (dc-loop-reg ".notify" 604 (lambda (r er)
  91                                    (let* ((ires (dc-intresp r))
  92                                           (new (list (cons 'id (car ires))
  93                                                      (cons 'net (cadr ires))
  94                                                      (cons 'name "")
  95                                                      (cons 'users 0)
  96                                                      (cons 'state 'syn))))
  97                                      (set! fnetnodes
  98                                            (cons (cons (car ires) new)
  99                                                  fnetnodes))
 100                                      (notify 'creat new))))
 101       (dc-loop-reg ".notify" 603 (lambda (r er)
 102                                    (let* ((ires (dc-intresp r)) (nform (assq (car ires) fnetnodes)))
 103                                      (notify 'dstr (cdr nform))
 104                                      (set! fnetnodes (delq nform fnetnodes))))))))
 105
 106 (define-public dc-loop-reg
 107   (lambda (cmd code proc)
 108     (set! loop-procs (cons (cons (cons cmd code) proc)
 109                            loop-procs))))
 110
 111 (define-public dc-loop
 112   (lambda ()
 113     (while #t
 114            (dc-select 10000)
 115            (while (let ((resp (dc-getresp)))
 116                     (if resp
 117                         (let* ((er (dc-extract resp)) (code (cdr (assq 'code er))) (cmd (cdr (assq 'cmd er))))
 118                           (for-each
 119                            (lambda (o)
 120                              (if (and (or (not (caar o)) (equal? cmd (caar o)))
 121                                       (or (not (cdar o)) (equal? code (cdar o))))
 122                                  ((cdr o) resp er)))
 123                            loop-procs))
 124                         #f))
 125                   #f)
 126            (for-each (lambda (o)
 127                        (if (equal? (caar o) ".periodic")
 128                            ((cdr o))))
 129                      loop-procs))))