| 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)) |
| 22 | (use-modules (ice-9 pretty-print) (ice-9 rdelim)) |
| 23 | |
| 24 | (define fnetnodes '()) |
| 25 | |
| 26 | (define (make-getopt opts optdesc) |
| 27 | (let ((arg opts) (curpos 0) (rest '())) |
| 28 | (lambda () |
| 29 | (if (eq? arg '()) rest |
| 30 | (let ((ret #f)) |
| 31 | (while (not ret) |
| 32 | (if (= curpos 0) |
| 33 | (if (eq? (string-ref (car arg) 0) #\-) |
| 34 | (set! curpos 1) |
| 35 | (begin |
| 36 | (set! rest (append rest (list (car arg)))) |
| 37 | (set! arg (cdr arg)) |
| 38 | (if (eq? arg '()) |
| 39 | (set! ret #t))))) |
| 40 | (if (> curpos 0) |
| 41 | (if (< curpos (string-length (car arg))) |
| 42 | (begin (set! ret (string-ref (car arg) curpos)) (set! curpos (+ curpos 1))) |
| 43 | (begin (set! curpos 0) (set! arg (cdr arg)) (if (eq? arg '()) (set! ret #t)))))) |
| 44 | (if (eq? ret #t) rest |
| 45 | (let ((opt (string-index optdesc ret))) |
| 46 | (if (eq? opt #f) (throw 'illegal-option ret) |
| 47 | (if (and (< opt (- (string-length optdesc) 1)) (eq? (string-ref optdesc (+ opt 1)) #\:)) |
| 48 | (let ((ret |
| 49 | (cons ret (let ((optarg |
| 50 | (if (< curpos (string-length (car arg))) |
| 51 | (substring (car arg) curpos) |
| 52 | (begin (set! arg (cdr arg)) (if (eq? arg '()) (throw 'requires-argument ret)) (car arg))))) |
| 53 | (set! arg (cdr arg)) optarg)))) |
| 54 | (set! curpos 0) |
| 55 | ret) |
| 56 | (list ret)))))))))) |
| 57 | |
| 58 | (define (fn-getnames) |
| 59 | (let ((resp (dc-ecmd "lsnodes")) (er #f)) |
| 60 | (if (and resp (begin (set! er (dc-extract resp)) er) (= (cdr (assoc 'code er)) 200)) |
| 61 | (let ((ires #f)) |
| 62 | (while (begin (set! ires (dc-intresp resp)) ires) |
| 63 | (if (assoc (car ires) fnetnodes) |
| 64 | (set-cdr! (assoc (car ires) fnetnodes) (list-ref ires 5)) |
| 65 | (set! fnetnodes (cons (cons (car ires) (list-ref ires 5)) fnetnodes)))))))) |
| 66 | |
| 67 | (define (fn-getname id) |
| 68 | (if (not (assoc id fnetnodes)) |
| 69 | (fn-getnames)) |
| 70 | (if (assoc id fnetnodes) |
| 71 | (cdr (assoc id fnetnodes)) |
| 72 | (number->string id))) |
| 73 | |
| 74 | ;(define (fn-getname id) |
| 75 | ; (let ((resp (dc-ecmd "lsnodes")) (er #f)) |
| 76 | ; (if (and resp (begin (set! er (dc-extract resp)) er) (= (cdr (assoc 'code er)) 200)) |
| 77 | ; (begin |
| 78 | ; (catch 'found |
| 79 | ; (lambda () |
| 80 | ; (let ((ires #f)) |
| 81 | ; (while (begin (set! ires (dc-intresp resp)) ires) |
| 82 | ; (if (= (car ires) id) |
| 83 | ; (throw 'found (caddr ires))) |
| 84 | ; )) |
| 85 | ; (number->string id) |
| 86 | ; ) |
| 87 | ; (lambda (key ret) |
| 88 | ; ret))) |
| 89 | ; (number->string id))) |
| 90 | ; ) |
| 91 | |
| 92 | (define (chatlog-main args) |
| 93 | (let ((dc-server #f) (log-dir #f) (last-fn #f)) |
| 94 | (let ((getopt (make-getopt (cdr args) "hs:S:e:")) (arg #f)) |
| 95 | (do ((arg (getopt) (getopt))) ((not (and (pair? arg) (char? (car arg)))) (set! args arg)) |
| 96 | (cond ((eq? (car arg) #\h) |
| 97 | (begin (display "usage: chatlog [-s server] [-d log-dir]\n" (current-error-port)) |
| 98 | (display " chatlog -h\n" (current-error-port)) |
| 99 | (exit 0))) |
| 100 | ((eq? (car arg) #\s) |
| 101 | (set! dc-server (cdr arg))) |
| 102 | ((eq? (car arg) #\d) |
| 103 | (set! log-dir (cdr arg))) |
| 104 | ) |
| 105 | ) |
| 106 | ) |
| 107 | (if (not log-dir) (set! log-dir (string-append (getenv "HOME") "/dc/chatlog"))) |
| 108 | |
| 109 | (dc-c&l #t dc-server #t) |
| 110 | (dc-ecmd-assert 200 "notify" "fn:chat" "on" "fn:act" "on") |
| 111 | |
| 112 | (while #t |
| 113 | (dc-select 10000) |
| 114 | (while (let ((resp (dc-getresp))) |
| 115 | (if resp |
| 116 | (begin |
| 117 | (let* ((er (dc-extract resp)) (code (cdr (assoc 'code er))) (cmd (cdr (assoc 'cmd er)))) |
| 118 | (cond |
| 119 | ((equal? cmd ".notify") |
| 120 | (case code |
| 121 | ((600) |
| 122 | (let ((ires (list->vector (dc-intresp resp)))) |
| 123 | (if ires |
| 124 | (let ((p (open-file |
| 125 | (string-append log-dir "/" |
| 126 | (let ((fixedname (list->string |
| 127 | (map (lambda (c) (if (eq? c #\/) #\_ c)) |
| 128 | (string->list (fn-getname (vector-ref ires 0))))))) |
| 129 | (if (= (string-length fixedname) 0) "noname" fixedname))) |
| 130 | "a"))) |
| 131 | (if (not (eq? (vector-ref ires 0) last-fn)) |
| 132 | (begin (write-line (string-append " -- " (fn-getname (vector-ref ires 0)) ":")) |
| 133 | (set! last-fn (vector-ref ires 0)))) |
| 134 | (for-each |
| 135 | (lambda (p) |
| 136 | (write-line (string-append (strftime "%H:%M:%S" (localtime (current-time))) (if (eq? (vector-ref ires 1) 0) "!" ":") " <" (vector-ref ires 3) "> " (vector-ref ires 4)) p)) |
| 137 | (list p (current-output-port))) |
| 138 | (close-port p)) |
| 139 | )) |
| 140 | ) |
| 141 | ; ((602) |
| 142 | ; (let ((ires (dc-intresp resp))) |
| 143 | ; (if ires |
| 144 | ; (let ((ent (assoc (car ires) fnetnodes))) |
| 145 | ; (if ent |
| 146 | ; (set-cdr! ent (cadr ires)) |
| 147 | ; (set! fnetnodes (cons (cons (car ires) (cadr ires)) fnetnodes))))))) |
| 148 | |
| 149 | ) |
| 150 | ) |
| 151 | |
| 152 | ) |
| 153 | ) |
| 154 | #t) |
| 155 | #f) |
| 156 | ) |
| 157 | #t |
| 158 | ) |
| 159 | |
| 160 | ) |
| 161 | ) |
| 162 | ) |
| 163 | |
| 164 | (chatlog-main (command-line)) |