tests/im/irc.scm

   1 (define-module (im irc)
   2     #:version (1 6 0)
   3     #:use-module (functional prelude)
   4     #:use-module (oop goops)
   5     #:use-module (ice-9 optargs)
   6     #:use-module (ice-9 receive)
   7     #:export (create-connection raw! run! join! quit! disconnect! hook-ref!))
   8 (load-extension "libguile-ircclient" "scm_init_im_irc")
   9
  10 (define-class <irc-session> ()
  11   (server #:getter &server)
  12   (nickname #:getter &nickname)
  13   event-hook-alist ;; (#:event . (hook arity))
  14   (ffi-session #:getter &ffi-session))
  15
  16 (define-method (initialize (obj <irc-session>) args)
  17   "Documenation to be written."
  18   (let-keywords
  19    args #f ((server (error "<irc-session>:: server must be specified"))
  20             (nickname (error "<irc-session>:: nickname must be specified"))
  21             (port 6667)
  22             server-password username realname ipv6)
  23    (slot-set! obj 'server server)
  24    (slot-set! obj 'nickname nickname)
  25    (initialize-event-hook-alist obj)
  26    (let ((ffi-session (irc-create-session obj event-dispatcher numeric-dispatcher)))
  27      (slot-set! obj 'ffi-session ffi-session)
  28      (irc-connect ffi-session server port nickname
  29                   server-password username realname ipv6))))
  30
  31
  32 (define-public (create-connection . args)
  33   (apply make <irc-session> args))
  34
  35
  36 (define-method (run! (obj <irc-session>))
  37   (irc-run (slot-ref obj 'ffi-session)))
  38
  39
  40 (define-method (join! (obj <irc-session>) (channel <string>) . args)
  41   (let-keywords args #f
  42                 ((password #f))
  43                 (irc-cmd-join (slot-ref obj 'ffi-session) channel password)))
  44
  45 (define-method (quit! (obj <irc-session>) . args)
  46   (let-keywords args #f
  47                 ((reason #f))
  48                 (irc-cmd-quit (slot-ref obj 'ffi-session) reason)))
  49 (define-method (raw! (obj <irc-session>) command)
  50   (irc-send-raw (slot-ref obj 'ffi-session) command))
  51
  52 (define-method (hook-ref! (obj <irc-session>) (event-keyword <keyword>))
  53   "Get hook for event "
  54   (car (or (assq-ref (slot-ref obj 'event-hook-alist) event-keyword)
  55            (error "Unsupported event" event-keyword))))
  56
  57 (define-method (disconnect! (obj <irc-session>))
  58   "Rude disconnect from server. Due bug in underlying library,
  59  do not use it."
  60   (irc-disconnect (slot-ref obj 'ffi-session)))
  61
  62 (define +event::symbol-arity-alist+
  63   '((#:connect . ()) ; <closure>
  64     (#:nick . (#f 0))  ; <closure> <old-nick> <new-nick>
  65     (#:quit . (#f 0)) ; <closure> <nick> <?reason>
  66     (#:join . (0 #f)) ; <closure> <channel> <nick>
  67     (#:part . (0 #f 1)) ; <closure> <channel> <nick> <?reason>
  68     (#:mode . (0 #f 1 2)) ; <closure> <channel> <nick> <mode> <?mode-args>
  69     (#:umode . (#f 0)) ; <closure> <nick> <mode>
  70     (#:topic . (0 #f 1)) ; <closure> <channel> <nick> <?new-topic>
  71     (#:kick . (0 #f 1 2)) ; <closure> <channel> <nick> <?victim> <?reason>
  72     (#:channel . (0 #f 1)) ;  <closure> <channel> <nick> <?text>
  73     (#:privmsg . (#f 1)) ; <closure> <visavi> <?text>
  74     (#:notice . (#f 1)) ; <closure> <source> <?text>
  75     (#:invite . (1 #f)))) ;<closure> <channel> <origin>
  76
  77 (define (get-arg origin params index)
  78   "Return argument, corresponding to `index`.
  79 If `index` equal -1, return origin, else params[index]."
  80   (if index
  81       (if (>= index (length params)) "" (list-ref params index))
  82       (irc-target-get-nick origin)))
  83
  84 (define (get-args origin params template)
  85   "Return list of arguments to pass to `run-hook`."
  86   (map (partial-apply get-arg origin params) template))
  87
  88 (define (event-dispatcher obj event-string origin params)
  89   "Dispatch C-API event handler to specific events hooks."
  90   (let* ((event-keyword (symbol->keyword (string->symbol (string-downcase event-string))))
  91          (hook&template (or (assq-ref (slot-ref obj 'event-hook-alist) event-keyword)
  92                             (error "Unhandled event." event-keyword)))
  93          (hook (car hook&template))
  94          (template (cdr hook&template)))
  95     (apply run-hook hook obj (get-args origin params template))))
  96
  97 (define (initialize-event-hook-alist obj)
  98   "Initialize event-hook-alist field of <irc-session> obj
  99 to list in format (#:event-keyword . (hook . hook-args-template))"
 100   (slot-set! obj 'event-hook-alist
 101              (map
 102               (lambda (pair)
 103                 (let* ((keyword (car pair))
 104                        (args-template (cdr pair))
 105                        (arity (1+ (length args-template))))
 106                   (cons
 107                    keyword
 108                    (cons (make-hook arity) args-template))))
 109               +event::symbol-arity-alist+)))
 110
 111 (define (numeric-dispatcher obj event-code origin params)
 112   (display (format "~d\n" event-code)))