lib/guile/hubmgr

   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) (ice-9 getopt-long))
  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 (define logdest #t)
  31 (define hl-mtime 0)
  32
  33 (define (logf . args)
  34   (let ((fmt (car args)) (args (cdr args)))
  35     (if logdest
  36         (apply format (cons* logdest (string-append fmt "~%") args)))))
  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)
  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) '()))))
  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))
  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)))
  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) '()))
  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))
  97                          (dc-qcmd (cons* "cnct" o)
  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))
 105                                                    (set! statelist (cons (list hub (current-time) 10) statelist))
 106                                                    (logf "~a failed (~a)" (cadr hub) (cdr (assq 'code er))))))))))))
 107             hublist))
 108
 109 (define (hubmgr-main args)
 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))
 114     (set! hublist (read-hl))
 115     (set! hl-mtime (stat:mtime (stat hl-file)))
 116     (logf "read ~a hubs" (length hublist))
 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")
 119     (dc-ecmd-assert 200 "register" "hubmgr")
 120     (dc-util-handle 'fn 'msg)
 121     (dc-fnproc-reg 'state (lambda (fn)
 122                             (if (and (eq? (cdr (assq 'state fn)) 'dead)
 123                                      (assq (cdr (assq 'id fn)) (map (lambda (o) (cons (cdr o) (car o))) connlist)))
 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)))
 135     (dc-msgproc-reg (lambda (sender msg)
 136                       (if (equal? (car msg) "exit")
 137                           (throw 'quit 0))))
 138     (dc-loop-reg ".periodic" #f cklist)
 139
 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))))
 145
 146     (for-each (lambda (sig) (sigaction sig (lambda (sig) (throw 'quit 0)))) (list SIGINT SIGTERM SIGHUP))
 147     (cklist)
 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))))
 159
 160 (setlocale LC_ALL "")
 161 (hubmgr-main (command-line))