lib/guile/chatlog

   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))
  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))