Fixed HTTP-client query-string handling bug.
[doldaconnect.git] / gnome-trans-applet / dctrmon
... / ...
CommitLineData
1#!/usr/bin/guile \
2--debug -s
3!#
4
5(use-modules (dolcon ui))
6(use-modules (ice-9 popen))
7(use-modules (ice-9 pretty-print))
8
9(define (flush port)
10 (force-output port))
11
12(define idlist '())
13(define filter '())
14(define (filtered tag filter)
15 (and (pair? filter)
16 (or (equal? (car filter) (substring tag 0 (min (string-length (car filter)) (string-length tag))))
17 (filtered tag (cdr filter)))))
18(catch 'system-error
19 (lambda ()
20 (let ((port (open-input-file (string-append (getenv "HOME") "/.dctrmon-defines"))) (form #f))
21 (while (begin (set! form (read port)) (not (eof-object? form)))
22 (primitive-eval form))))
23 (lambda args
24 #f))
25
26
27(define krbcc (string-append "/tmp/krb5cc_dcmon_" (number->string (getuid)) "_XXXXXX"))
28(close-port (mkstemp! krbcc))
29(setenv "KRB5CCNAME" (string-append "FILE:" krbcc))
30(sigaction SIGCHLD SIG_DFL)
31(define pid (primitive-fork))
32(if (= pid 0)
33 (begin (execlp "kinit" "kinit" "-f" "-r" "10d" "-k" "-t" (string-append (getenv "HOME") "/.myprinc.keytab") (string-append (passwd:name (getpwuid (getuid))) "/dcview"))
34 (exit 1))
35 (if (not (= (cdr (waitpid pid)) 0))
36 (exit 1)))
37(dc-c&l #f (getenv "DCSERVER") #t)
38(delete-file krbcc)
39
40(dc-ecmd-assert 200 "notify" "all" "on")
41
42(display "C\n")
43
44(let ((resp (dc-ecmd-assert '(200 201) "lstrans")))
45 (if (and resp (= (cdr (assoc 'code (dc-extract resp))) 200))
46 (for-each (lambda (o)
47 (if (= (cadr o) 2)
48 (catch 'bad-return
49 (lambda ()
50 (for-each (lambda (a)
51 (if (and (equal? (car a) "tag") (filtered (cadr a) filter))
52 (begin
53 (display (string-append "N\t" (cadr a) "\t" (number->string (list-ref o 6)) "\t" (number->string (list-ref o 7)) "\n"))
54 (set! idlist (append idlist (list (cons (car o) (cadr a))))))))
55 (dc-intall (dc-ecmd-assert 200 "lstrarg" (car o)))))
56 (lambda args #f))))
57 (dc-intall resp))))
58
59(flush (current-output-port))
60
61(while #t
62 (dc-select 10000)
63 (while (let ((resp (dc-getresp)))
64 (if resp
65 (begin
66 (let* ((er (dc-extract resp)) (code (cdr (assoc 'code er))) (cmd (cdr (assoc 'cmd er))) (ir (dc-intresp resp)))
67 (if (equal? cmd ".notify")
68 (case code
69 ((610)
70 (let* ((id (car ir)) (ir2 (dc-intall (dc-ecmd-assert '(200 201) "lstrarg" id))) (tag (if (eq? (car ir2) '()) #f (assoc "tag" ir2))))
71 (if (and tag (filtered (cadr tag) filter))
72 (begin (display (string-append "N\t" (cadr tag) "\t-1\t-1\n"))
73 (flush (current-output-port))
74 (set! idlist (append idlist (list (cons (car ir) (cadr tag)))))))))
75 ((613)
76 (let ((id (car ir)))
77 (if (assoc id idlist)
78 (begin (display (string-append "S\t" (cdr (assoc id idlist)) "\t" (number->string (cadr ir)) "\n"))
79 (flush (current-output-port))))))
80 ((615)
81 (let ((id (car ir)))
82 (if (assoc id idlist)
83 (begin (display (string-append "P\t" (cdr (assoc id idlist)) "\t" (number->string (cadr ir)) "\n"))
84 (flush (current-output-port))))))
85 ((617)
86 (let ((id (car ir)))
87 (if (assoc id idlist)
88 (begin (display (string-append "D\t" (cdr (assoc id idlist)) "\n"))
89 (flush (current-output-port)))))))))
90 #t)
91 #f)) #f))
92
93(dc-disconnect)