#!/usr/bin/guile -s
!#
+; Dolda Connect - Modular multiuser Direct Connect-style client
+; Copyright (C) 2007 Fredrik Tolf <fredrik@dolda2000.com>
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 2 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
(use-modules (dolcon ui) (dolcon util))
-(use-modules (ice-9 format))
+(use-modules (ice-9 format) (ice-9 rdelim) (ice-9 getopt-long))
(define max-hubs 6)
(define hub-list '())
(define hublist '())
(define connlist '())
(define statelist '())
+(define logdest #t)
+(define hl-mtime 0)
(define (logf . args)
(let ((fmt (car args)) (args (cdr args)))
- (apply format (cons* #t (string-append fmt "~%") args))))
+ (if logdest
+ (apply format (cons* logdest (string-append fmt "~%") args)))))
(define (list-delta l1 l2)
(let ((r1 '()) (r2 '()))
(list r1 r2 l2)))
(define (read-hl)
- (catch 'system-error
- (lambda ()
- (let ((p (open-input-file hl-file)))
- (catch 'eof
- (lambda ()
- (let ((lines '()))
- (while #t
- (let ((line (read-line p)))
- (if (eof-object? line)
- (throw 'eof lines)
- (let ((lexed (dc-lexsexpr line)))
- (if (> (length lexed) 0)
- (set! lines (append lines (list lexed))))))))))
- (lambda (s a) (close-port p) a))))
- (lambda (key . args)
- '())))
+ (letrec ((read-lines (lambda (lines p)
+ (let ((line (read-line p)))
+ (if (eof-object? line)
+ (begin (close-port p)
+ lines)
+ (read-lines (let ((lexed (dc-lexsexpr line)))
+ (if (and (> (length lexed) 0)
+ (not (eq? (string-ref (car lexed) 0) #\#)))
+ (append lines (list lexed))
+ lines)) p))))))
+ (catch 'system-error
+ (lambda () (read-lines '() (open-input-file hl-file)))
+ (lambda (key . args) '()))))
(define (cklist)
(set! statelist (let ((nl '()) (ct (current-time)))
(set! nl (cons o nl))))
statelist)
nl))
+ (catch 'system-error
+ (lambda ()
+ (let ((mtime (stat:mtime (stat hl-file))))
+ (if (> mtime hl-mtime)
+ (let* ((delta (list-delta hublist (read-hl)))
+ (same (car delta))
+ (del (cadr delta))
+ (new (caddr delta)))
+ (for-each (lambda (o)
+ (let ((el (assq o connlist)))
+ (if el
+ (begin (if (not (eq? (cdr el) 'pend))
+ (dc-qcmd (list "dcnct" (cdr el))))
+ (set! connlist (delq el connlist))))))
+ del)
+ (set! hublist (append (map (lambda (o) (car o)) same) new))
+ (set! hl-mtime mtime)))))
+ (lambda (key . args) '()))
(for-each (lambda (o)
(if (and (not (assq o connlist))
(not (assq o statelist)))
(begin (logf "connecting to ~a" (cadr o))
(set! connlist (cons (cons o 'pend) connlist))
- (dc-qcmd (list* "cnct" o)
+ (dc-qcmd (cons* "cnct" o)
(let ((hub o))
(lambda (resp)
(let ((er (dc-extract resp)) (ir (dc-intresp resp)))
(begin (set-cdr! (assq hub connlist) (car ir))
(logf "~a state syn (~a)" (cadr hub) (car ir)))
(begin (set! connlist (delq (assq hub connlist) connlist))
+ (set! statelist (cons (list hub (current-time) 10) statelist))
(logf "~a failed (~a)" (cadr hub) (cdr (assq 'code er))))))))))))
hublist))
(define (hubmgr-main args)
- (let ((dc-server #f))
- (if (not dc-server) (set! dc-server (getenv "DCSERVER")))
- (if (not dc-server) (set! dc-server "localhost"))
-
+ (let ((opts (getopt-long args '((nodaemon (single-char #\d) (value #f))
+ (server (single-char #\s) (value #t))
+ (quiet (single-char #\q) (value #f))))))
+ (if (option-ref opts 'quiet #f) (set! logdest #f))
(set! hublist (read-hl))
+ (set! hl-mtime (stat:mtime (stat hl-file)))
(logf "read ~a hubs" (length hublist))
- (dc-c&l #t dc-server #t)
- (dc-ecmd-assert 200 "notify" "fn:act" "on")
- (dc-handle-fn)
+ (dc-c&l (not (option-ref opts 'quiet #f)) (option-ref opts 'server #f) #t)
+ (dc-ecmd-assert 200 "notify" "fn:act" "on" "msg" "on")
+ (dc-ecmd-assert 200 "register" "hubmgr")
+ (dc-util-handle 'fn 'msg)
(dc-fnproc-reg 'state (lambda (fn)
(if (and (eq? (cdr (assq 'state fn)) 'dead)
(assq (cdr (assq 'id fn)) (map (lambda (o) (cons (cdr o) (car o))) connlist)))
(set! connlist (delq (assq hlf connlist) connlist))
(set! statelist (cons (list hlf (current-time) 10) statelist)))))
(cklist)))
+ (dc-msgproc-reg (lambda (sender msg)
+ (if (equal? (car msg) "exit")
+ (throw 'quit 0))))
(dc-loop-reg ".periodic" #f cklist)
+ (if (not (option-ref opts 'nodaemon #f))
+ (begin (logf "daemonizing...")
+ (if (= (primitive-fork) 0)
+ (set! logdest #f)
+ (primitive-exit 0))))
+
+ (for-each (lambda (sig) (sigaction sig (lambda (sig) (throw 'quit 0)))) (list SIGINT SIGTERM SIGHUP))
(cklist)
- (dc-loop)))
+ (catch 'quit dc-loop
+ (lambda (sig ret)
+ (catch 'quit
+ (lambda ()
+ (for-each (lambda (o)
+ (if (not (eq? (cdr o) 'pend))
+ (dc-ecmd "dcnct" (cdr o))))
+ connlist)
+ )
+ (lambda (sig ret) ret))
+ ret))))
(setlocale LC_ALL "")
(hubmgr-main (command-line))
Dolda2000 GitWeb / doldaconnect.git / blobdiff