lib/guile/chatlog

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