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