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)) |
f4473d02 | 22 | (use-modules (ice-9 format) (ice-9 rdelim) (ice-9 getopt-long)) |
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 '()) | |
f4473d02 | 30 | (define logdest #t) |
6b081952 | 31 | |
32 | (define (logf . args) | |
33 | (let ((fmt (car args)) (args (cdr args))) | |
f4473d02 FT |
34 | (if logdest |
35 | (apply format (cons* logdest (string-append fmt "~%") args))))) | |
6b081952 | 36 | |
37 | (define (list-delta l1 l2) | |
38 | (let ((r1 '()) (r2 '())) | |
39 | (for-each (lambda (o1) | |
40 | (catch 'found | |
41 | (lambda () | |
42 | (for-each (lambda (o2) | |
43 | (if (equal? o1 o2) (throw 'found o2))) | |
44 | l2) | |
45 | (set! r2 (cons o1 r2))) | |
46 | (lambda (sig ret) | |
47 | (set! r1 (cons (cons o1 ret) r1)) | |
48 | (set! l2 (delq ret l2))))) | |
49 | l1) | |
50 | (list r1 r2 l2))) | |
51 | ||
52 | (define (read-hl) | |
91328d65 FT |
53 | (letrec ((read-lines (lambda (lines p) |
54 | (let ((line (read-line p))) | |
55 | (if (eof-object? line) | |
56 | (begin (close-port p) | |
57 | lines) | |
58 | (read-lines (let ((lexed (dc-lexsexpr line))) | |
59 | (if (> (length lexed) 0) | |
60 | (append lines (list lexed)) | |
61 | lines)) p)))))) | |
62 | (catch 'system-error | |
63 | (lambda () (read-lines '() (open-input-file hl-file))) | |
64 | (lambda (key . args) '())))) | |
6b081952 | 65 | |
66 | (define (cklist) | |
67 | (set! statelist (let ((nl '()) (ct (current-time))) | |
68 | (for-each (lambda (o) | |
69 | (if (< ct (+ (cadr o) (caddr o))) | |
70 | (set! nl (cons o nl)))) | |
71 | statelist) | |
72 | nl)) | |
73 | (for-each (lambda (o) | |
74 | (if (and (not (assq o connlist)) | |
75 | (not (assq o statelist))) | |
76 | (begin (logf "connecting to ~a" (cadr o)) | |
77 | (set! connlist (cons (cons o 'pend) connlist)) | |
ae958036 | 78 | (dc-qcmd (cons* "cnct" o) |
6b081952 | 79 | (let ((hub o)) |
80 | (lambda (resp) | |
81 | (let ((er (dc-extract resp)) (ir (dc-intresp resp))) | |
82 | (if (= (cdr (assq 'code er)) 200) | |
83 | (begin (set-cdr! (assq hub connlist) (car ir)) | |
84 | (logf "~a state syn (~a)" (cadr hub) (car ir))) | |
85 | (begin (set! connlist (delq (assq hub connlist) connlist)) | |
4024acee | 86 | (set! statelist (cons (list hub (current-time) 10) statelist)) |
6b081952 | 87 | (logf "~a failed (~a)" (cadr hub) (cdr (assq 'code er)))))))))))) |
88 | hublist)) | |
89 | ||
90 | (define (hubmgr-main args) | |
ae958036 FT |
91 | (let ((opts (getopt-long args '((nodaemon (single-char #\d) (value #f)) |
92 | (server (single-char #\s) (value #t)) | |
93 | (quiet (single-char #\q) (value #f)))))) | |
94 | (if (option-ref opts 'quiet #f) (set! logdest #f)) | |
6b081952 | 95 | (set! hublist (read-hl)) |
96 | (logf "read ~a hubs" (length hublist)) | |
ae958036 FT |
97 | (dc-c&l (not (option-ref opts 'quiet #f)) (option-ref opts 'server #f) #t) |
98 | (dc-ecmd-assert 200 "notify" "fn:act" "on" "msg" "on") | |
f4473d02 | 99 | (dc-ecmd-assert 200 "register" "hubmgr") |
ae958036 | 100 | (dc-util-handle 'fn 'msg) |
6b081952 | 101 | (dc-fnproc-reg 'state (lambda (fn) |
2a156d4f | 102 | (if (and (eq? (cdr (assq 'state fn)) 'dead) |
103 | (assq (cdr (assq 'id fn)) (map (lambda (o) (cons (cdr o) (car o))) connlist))) | |
6b081952 | 104 | (begin (logf "~a died" (cdr (assq 'id fn))) |
105 | (dc-qcmd (list "dcnct" (cdr (assq 'id fn)))))) | |
106 | (cklist))) | |
107 | (dc-fnproc-reg 'dstr (lambda (fn) | |
108 | (let ((clf (assq (cdr (assq 'id fn)) (map (lambda (o) (cons (cdr o) (car o))) connlist)))) | |
109 | (if clf | |
110 | (let ((hlf (cdr clf))) | |
111 | (logf "~a disappeared" (cadr hlf)) | |
112 | (set! connlist (delq (assq hlf connlist) connlist)) | |
113 | (set! statelist (cons (list hlf (current-time) 10) statelist))))) | |
114 | (cklist))) | |
ae958036 FT |
115 | (dc-msgproc-reg (lambda (sender msg) |
116 | (if (equal? (car msg) "exit") | |
117 | (throw 'quit 0)))) | |
6b081952 | 118 | (dc-loop-reg ".periodic" #f cklist) |
119 | ||
ae958036 FT |
120 | (if (not (option-ref opts 'nodaemon #f)) |
121 | (begin (logf "daemonizing...") | |
122 | (if (= (primitive-fork) 0) | |
123 | (set! logdest #f) | |
124 | (primitive-exit 0)))) | |
f4473d02 | 125 | |
ae958036 | 126 | (for-each (lambda (sig) (sigaction sig (lambda (sig) (throw 'quit 0)))) (list SIGINT SIGTERM SIGHUP)) |
6b081952 | 127 | (cklist) |
ae958036 FT |
128 | (catch 'quit dc-loop |
129 | (lambda (sig ret) | |
130 | (catch 'quit | |
131 | (lambda () | |
132 | (for-each (lambda (o) | |
133 | (if (not (eq? (cdr o) 'pend)) | |
134 | (dc-ecmd "dcnct" (cdr o)))) | |
135 | connlist) | |
136 | ) | |
137 | (lambda (sig ret) ret)) | |
138 | ret)))) | |
6b081952 | 139 | |
140 | (setlocale LC_ALL "") | |
141 | (hubmgr-main (command-line)) |