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 (define msg-procs '())
  25 (define timeouts '())
  26
  27 (define-public dc-fn-update
  28   (lambda ()
  29     (set! fnetnodes
  30           (let ((resp (dc-ecmd "lsnodes")) (er #f))
  31             (if (and resp (begin (set! er (dc-extract resp)) er) (= (cdr (assq 'code er)) 200))
  32                 (map (lambda (o)
  33                        (apply (lambda (id net name users state uid)
  34                                 (cons id
  35                                       (list (cons 'id id)
  36                                             (cons 'net net)
  37                                             (cons 'name name)
  38                                             (cons 'users users)
  39                                             (cons 'state (list-ref '(syn hs est dead) state))
  40                                             (cons 'uid uid))))
  41                               o))
  42                      (dc-intall resp))
  43                 '())))
  44     fnetnodes))
  45
  46 (define-public dc-fn-getattrib
  47   (lambda (id attrib)
  48     (if (not (assq id fnetnodes))
  49         (dc-fn-update))
  50     (let ((aform (assq id fnetnodes)))
  51       (if aform
  52           (cdr (assq attrib (cdr aform)))
  53           #f))))
  54
  55 (define-public dc-fn-getname
  56   (lambda (id)
  57     (dc-fn-getattrib id 'name)))
  58
  59 (define-public dc-getfnetnodes
  60   (lambda ()
  61     (map (lambda (o) (car o))
  62          fnetnodes)))
  63
  64 (define fn-updattr
  65   (lambda (id attr val)
  66     (let ((aform (assq id fnetnodes)))
  67       (if aform
  68           (set-cdr! (assq attr (cdr aform)) val)
  69           #f))))
  70
  71 (define-public dc-fnproc-reg
  72   (lambda (event proc)
  73     (set! fn-procs (cons (list event proc)
  74                          fn-procs))))
  75
  76 (define dc-handle-fn
  77   (lambda ()
  78     (dc-fn-update)
  79     (let* ((notify (lambda (event data) (for-each (lambda (o) (if (eq? event (car o)) ((cadr o) data))) fn-procs)))
  80            (ua (lambda (r a) (let* ((ires (dc-intresp r))
  81                                     (hubform (assq (car ires) fnetnodes)))
  82                                (if hubform
  83                                    (begin (fn-updattr (car ires) a (cadr ires))
  84                                           (notify a (cdr (assq (car ires) fnetnodes)))))))))
  85       (dc-loop-reg ".notify" 601 (lambda (r er) (let* ((ires (dc-intresp r))
  86                                                        (hubform (assq (car ires) fnetnodes)))
  87                                                   (if hubform
  88                                                       (begin (fn-updattr (car ires) 'state (list-ref '(syn hs est dead) (cadr ires)))
  89                                                              (notify 'state (cdr hubform)))))))
  90       (dc-loop-reg ".notify" 602 (lambda (r er) (ua r 'name)))
  91       (dc-loop-reg ".notify" 605 (lambda (r er) (ua r 'users)))
  92       (dc-loop-reg ".notify" 604 (lambda (r er)
  93                                    (let* ((ires (dc-intresp r))
  94                                           (new (list (cons 'id (car ires))
  95                                                      (cons 'net (cadr ires))
  96                                                      (cons 'name "")
  97                                                      (cons 'users 0)
  98                                                      (cons 'state 'syn))))
  99                                      (set! fnetnodes
 100                                            (cons (cons (car ires) new)
 101                                                  fnetnodes))
 102                                      (notify 'creat new))))
 103       (dc-loop-reg ".notify" 603 (lambda (r er)
 104                                    (let* ((ires (dc-intresp r)) (nform (assq (car ires) fnetnodes)))
 105                                      (notify 'dstr (cdr nform))
 106                                      (set! fnetnodes (delq nform fnetnodes))))))))
 107
 108 (define-public dc-msgproc-reg
 109   (lambda (proc)
 110     (set! msg-procs (cons proc msg-procs))))
 111
 112 (define dc-handle-msg
 113   (lambda ()
 114     (dc-loop-reg ".notify" 640 (lambda (r er)
 115                                  (let ((sender (cadadr (assq 'resp er)))
 116                                        (message (cddadr (assq 'resp er))))
 117                                    (for-each (lambda (o) (o sender message))
 118                                              msg-procs))))))
 119
 120 (define-public dc-util-handle
 121   (lambda what
 122     (for-each (lambda (o)
 123                 (case o
 124                   ((fn) (dc-handle-fn))
 125                   ((msg) (dc-handle-msg))))
 126               what)))
 127
 128 (define-public dc-timeout
 129   (lambda (rel timeout proc)
 130     (let* ((tf (gettimeofday))
 131            (t (+ (car tf) (/ (cdr tf) 1000000))))
 132       (set! timeouts (merge timeouts (list (cons (if rel (+ timeout t) timeout) proc))
 133                             (lambda (a b) (< (car a) (car b))))))))
 134
 135 (define-public dc-loop-reg
 136   (lambda (cmd code proc)
 137     (set! loop-procs (cons (cons (cons cmd code) proc)
 138                            loop-procs))))
 139
 140 (define-public dc-loop
 141   (lambda ()
 142     (while #t
 143            (dc-select (if (eq? timeouts '())
 144                           10000
 145                           (let* ((tf (gettimeofday))
 146                                  (t (+ (car tf) (/ (cdr tf) 1000000)))
 147                                  (dt (- (caar timeouts) t)))
 148                             (if (< dt 0) 0 (truncate (inexact->exact (* dt 1000)))))))
 149            (while (let ((resp (dc-getresp)))
 150                     (if resp
 151                         (let* ((er (dc-extract resp)) (code (cdr (assq 'code er))) (cmd (cdr (assq 'cmd er))))
 152                           (for-each
 153                            (lambda (o)
 154                              (if (and (or (not (caar o)) (equal? cmd (caar o)))
 155                                       (or (not (cdar o)) (equal? code (cdar o))))
 156                                  ((cdr o) resp er)))
 157                            loop-procs))
 158                         #f))
 159                   #f)
 160            (while (and (not (eq? timeouts '()))
 161                        (let* ((tf (gettimeofday))
 162                              (t (+ (car tf) (/ (cdr tf) 1000000))))
 163                          (>= t (caar timeouts))))
 164                   ((cdar timeouts))
 165                   (set! timeouts (cdr timeouts)))
 166            (for-each (lambda (o)
 167                        (if (equal? (caar o) ".periodic")
 168                            ((cdr o))))
 169                      loop-procs))))