Port Scheme programs to Guile 1.8.
[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))
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))