| 1 | #!/usr/bin/guile -s |
| 2 | !# |
| 3 | |
| 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 | |
| 21 | (use-modules (dolcon ui) (dolcon util)) |
| 22 | (use-modules (ice-9 format) (ice-9 rdelim)) |
| 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)) |
| 88 | (set! statelist (cons (list hub (current-time) 10) statelist)) |
| 89 | (logf "~a failed (~a)" (cadr hub) (cdr (assq 'code er)))))))))))) |
| 90 | hublist)) |
| 91 | |
| 92 | (define (hubmgr-main args) |
| 93 | (let ((dc-server #f)) |
| 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) |
| 100 | (if (and (eq? (cdr (assq 'state fn)) 'dead) |
| 101 | (assq (cdr (assq 'id fn)) (map (lambda (o) (cons (cdr o) (car o))) connlist))) |
| 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)) |