| d3372da9 |
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) |
Dolda2000 GitWeb / doldaconnect.git / blame