Commit | Line | Data |
---|---|---|
6b081952 | 1 | #!/usr/bin/guile -s |
2 | !# | |
3 | ||
3af4536f FT |
4 | ; Dolda Connect - Modular multiuser Direct Connect-style client |
5 | ; Copyright (C) 2007 Fredrik Tolf <fredrik@dolda2000.com> | |
6 | ; | |
7 | ; This program is free software; you can redistribute it and/or modify | |
8 | ; it under the terms of the GNU General Public License as published by | |
9 | ; the Free Software Foundation; either version 2 of the License, or | |
10 | ; (at your option) any later version. | |
11 | ; | |
12 | ; This program is distributed in the hope that it will be useful, | |
13 | ; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ; GNU General Public License for more details. | |
16 | ; | |
17 | ; You should have received a copy of the GNU General Public License | |
18 | ; along with this program; if not, write to the Free Software | |
19 | ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
20 | ||
6b081952 | 21 | (use-modules (dolcon ui) (dolcon util)) |
275514c0 | 22 | (use-modules (ice-9 format) (ice-9 rdelim)) |
6b081952 | 23 | |
24 | (define max-hubs 6) | |
25 | (define hub-list '()) | |
26 | (define hl-file (string-append (getenv "HOME") "/.hublist")) | |
27 | (define hublist '()) | |
28 | (define connlist '()) | |
29 | (define statelist '()) | |
30 | ||
31 | (define (logf . args) | |
32 | (let ((fmt (car args)) (args (cdr args))) | |
33 | (apply format (cons* #t (string-append fmt "~%") args)))) | |
34 | ||
35 | (define (list-delta l1 l2) | |
36 | (let ((r1 '()) (r2 '())) | |
37 | (for-each (lambda (o1) | |
38 | (catch 'found | |
39 | (lambda () | |
40 | (for-each (lambda (o2) | |
41 | (if (equal? o1 o2) (throw 'found o2))) | |
42 | l2) | |
43 | (set! r2 (cons o1 r2))) | |
44 | (lambda (sig ret) | |
45 | (set! r1 (cons (cons o1 ret) r1)) | |
46 | (set! l2 (delq ret l2))))) | |
47 | l1) | |
48 | (list r1 r2 l2))) | |
49 | ||
50 | (define (read-hl) | |
51 | (catch 'system-error | |
52 | (lambda () | |
53 | (let ((p (open-input-file hl-file))) | |
54 | (catch 'eof | |
55 | (lambda () | |
56 | (let ((lines '())) | |
57 | (while #t | |
58 | (let ((line (read-line p))) | |
59 | (if (eof-object? line) | |
60 | (throw 'eof lines) | |
61 | (let ((lexed (dc-lexsexpr line))) | |
62 | (if (> (length lexed) 0) | |
63 | (set! lines (append lines (list lexed)))))))))) | |
64 | (lambda (s a) (close-port p) a)))) | |
65 | (lambda (key . args) | |
66 | '()))) | |
67 | ||
68 | (define (cklist) | |
69 | (set! statelist (let ((nl '()) (ct (current-time))) | |
70 | (for-each (lambda (o) | |
71 | (if (< ct (+ (cadr o) (caddr o))) | |
72 | (set! nl (cons o nl)))) | |
73 | statelist) | |
74 | nl)) | |
75 | (for-each (lambda (o) | |
76 | (if (and (not (assq o connlist)) | |
77 | (not (assq o statelist))) | |
78 | (begin (logf "connecting to ~a" (cadr o)) | |
79 | (set! connlist (cons (cons o 'pend) connlist)) | |
80 | (dc-qcmd (list* "cnct" o) | |
81 | (let ((hub o)) | |
82 | (lambda (resp) | |
83 | (let ((er (dc-extract resp)) (ir (dc-intresp resp))) | |
84 | (if (= (cdr (assq 'code er)) 200) | |
85 | (begin (set-cdr! (assq hub connlist) (car ir)) | |
86 | (logf "~a state syn (~a)" (cadr hub) (car ir))) | |
87 | (begin (set! connlist (delq (assq hub connlist) connlist)) | |
4024acee | 88 | (set! statelist (cons (list hub (current-time) 10) statelist)) |
6b081952 | 89 | (logf "~a failed (~a)" (cadr hub) (cdr (assq 'code er)))))))))))) |
90 | hublist)) | |
91 | ||
92 | (define (hubmgr-main args) | |
93 | (let ((dc-server #f)) | |
6b081952 | 94 | (set! hublist (read-hl)) |
95 | (logf "read ~a hubs" (length hublist)) | |
96 | (dc-c&l #t dc-server #t) | |
97 | (dc-ecmd-assert 200 "notify" "fn:act" "on") | |
98 | (dc-handle-fn) | |
99 | (dc-fnproc-reg 'state (lambda (fn) | |
2a156d4f | 100 | (if (and (eq? (cdr (assq 'state fn)) 'dead) |
101 | (assq (cdr (assq 'id fn)) (map (lambda (o) (cons (cdr o) (car o))) connlist))) | |
6b081952 | 102 | (begin (logf "~a died" (cdr (assq 'id fn))) |
103 | (dc-qcmd (list "dcnct" (cdr (assq 'id fn)))))) | |
104 | (cklist))) | |
105 | (dc-fnproc-reg 'dstr (lambda (fn) | |
106 | (let ((clf (assq (cdr (assq 'id fn)) (map (lambda (o) (cons (cdr o) (car o))) connlist)))) | |
107 | (if clf | |
108 | (let ((hlf (cdr clf))) | |
109 | (logf "~a disappeared" (cadr hlf)) | |
110 | (set! connlist (delq (assq hlf connlist) connlist)) | |
111 | (set! statelist (cons (list hlf (current-time) 10) statelist))))) | |
112 | (cklist))) | |
113 | (dc-loop-reg ".periodic" #f cklist) | |
114 | ||
115 | (cklist) | |
116 | (dc-loop))) | |
117 | ||
118 | (setlocale LC_ALL "") | |
119 | (hubmgr-main (command-line)) |