Crude IRC driver and example.
This commit is contained in:
parent
7cc62688f9
commit
eb4a228c73
|
@ -0,0 +1,109 @@
|
|||
#lang syndicate/actor
|
||||
;; Dreadfully simplified IRC client driver.
|
||||
|
||||
(provide (struct-out irc-connection)
|
||||
(struct-out irc-presence)
|
||||
(struct-out irc-inbound)
|
||||
(struct-out irc-outbound))
|
||||
|
||||
(define-logger syndicate/drivers/irc)
|
||||
|
||||
(require racket/format)
|
||||
(require racket/set)
|
||||
(require racket/string)
|
||||
|
||||
(require syndicate/protocol/advertise)
|
||||
|
||||
(require/activate syndicate/supervise)
|
||||
(require/activate "tcp.rkt")
|
||||
(require/activate "line-reader.rkt")
|
||||
|
||||
(struct irc-connection (host port nick) #:prefab) ;; ASSERTION
|
||||
|
||||
(struct irc-presence (conn nick channel) #:prefab) ;; ASSERTION
|
||||
(struct irc-inbound (conn nick target body) #:prefab) ;; MESSAGE
|
||||
(struct irc-outbound (conn target body) #:prefab) ;; MESSAGE
|
||||
|
||||
(actor #:name 'irc-connection-factory
|
||||
|
||||
(during (observe (irc-inbound $C _ _ _))
|
||||
(assert C))
|
||||
|
||||
(during (observe (observe (irc-outbound $C _ _)))
|
||||
(assert C))
|
||||
|
||||
(during/actor (irc-connection $host $port $nick)
|
||||
#:actor supervise/actor
|
||||
#:name (list 'irc-connection host port nick)
|
||||
(define C (irc-connection host port nick))
|
||||
(define LH (tcp-handle (gensym 'irc)))
|
||||
(define RH (tcp-address host port))
|
||||
|
||||
(define (irc-send! . pieces)
|
||||
(send! (tcp-channel LH RH (string->bytes/utf-8
|
||||
(string-append
|
||||
(apply string-append (map ~a pieces))
|
||||
"\r\n")))))
|
||||
|
||||
(on (asserted (advertise (tcp-channel RH LH _)))
|
||||
(irc-send! "NICK "nick)
|
||||
(irc-send! "USER "nick" 0 * :"nick)
|
||||
(react
|
||||
(during (observe (irc-inbound C _ $target _))
|
||||
(when (string-prefix? target "#")
|
||||
(on-start (irc-send! "JOIN :"target))
|
||||
(on-stop (irc-send! "PART :"target))))
|
||||
(on (message (irc-outbound C $target $body))
|
||||
(irc-send! "PRIVMSG "target" :"body)
|
||||
(send! (irc-inbound C nick target body)))))
|
||||
|
||||
(stop-when (retracted (advertise (tcp-channel RH LH _))))
|
||||
(assert (advertise (tcp-channel LH RH _)))
|
||||
|
||||
(field [names-tgt #f]
|
||||
[names-acc (set)])
|
||||
|
||||
(on (message (tcp-channel-line RH LH $line-bytes))
|
||||
(log-syndicate/drivers/irc-debug "irc got ~v" line-bytes)
|
||||
(match line-bytes
|
||||
[(regexp #px#"^PING(.*)\r$" (list _ line-tail))
|
||||
(irc-send! "PONG"line-tail)]
|
||||
[(regexp #px#"^:([^!]+)![^ ]* PRIVMSG ([^ ]+) :(.*)\r$" (list _ src tgt body))
|
||||
(send! (irc-inbound C
|
||||
(bytes->string/utf-8 src)
|
||||
(bytes->string/utf-8 tgt)
|
||||
(bytes->string/utf-8 body)))]
|
||||
[(regexp #px#"^:[^ ]* 353 [^:]+ ([^ ]+) :(.*)\r$" (list _ tgt names))
|
||||
(names-tgt (bytes->string/utf-8 tgt))
|
||||
(define new-names
|
||||
(for/set [(n (string-split (bytes->string/utf-8 names)))]
|
||||
(match n
|
||||
[(regexp #px"@(.*)" (list _ n1)) n1]
|
||||
[(regexp #px"\\+(.*)" (list _ n1)) n1]
|
||||
[n1 n1])))
|
||||
(log-syndicate/drivers/irc-debug "New names ~v ~v" (names-tgt) new-names)
|
||||
(names-acc (set-union (names-acc) new-names))]
|
||||
[(regexp #px#"^:[^ ]* 366 " (list _))
|
||||
(log-syndicate/drivers/irc-debug "Final names ~v" (names-acc))
|
||||
(retract! (irc-presence C ? (names-tgt)))
|
||||
(for ((n (names-acc)))
|
||||
(assert! (irc-presence C n (names-tgt))))
|
||||
(assert! (irc-presence C nick (names-tgt)))
|
||||
;; ^ (*) Here we note our own presence. We don't do it
|
||||
;; in response to our own JOIN because we want to make
|
||||
;; sure that our presence is marked *last* to help
|
||||
;; preserve some semblance of causal ordering... This
|
||||
;; is pretty hacky!
|
||||
(names-tgt #f)
|
||||
(names-acc (set))]
|
||||
[(regexp #px#"^:([^!]+)![^ ]* PART ([^ ]+)\r$" (list _ src tgt))
|
||||
(retract! (irc-presence C
|
||||
(bytes->string/utf-8 src)
|
||||
(bytes->string/utf-8 tgt)))]
|
||||
[(regexp #px#"^:([^!]+)![^ ]* JOIN ([^ ]+)\r$" (list _ src-bs tgt))
|
||||
(define src (bytes->string/utf-8 src-bs))
|
||||
(when (not (equal? src nick)) ;; See above marked (*)
|
||||
(assert! (irc-presence C
|
||||
src
|
||||
(bytes->string/utf-8 tgt))))]
|
||||
[_ (void)]))))
|
|
@ -0,0 +1,25 @@
|
|||
#lang syndicate/actor
|
||||
|
||||
(require/activate syndicate/drivers/irc)
|
||||
|
||||
(define NICK "syndicatebot")
|
||||
(define CHAN "##syndicatelang")
|
||||
(define C (irc-connection "irc.freenode.net" 6667 NICK))
|
||||
|
||||
(actor #:name 'irc-connection-example
|
||||
|
||||
(on (message (irc-inbound C $who NICK $body))
|
||||
(log-info "~a said to me: ~a" who body)
|
||||
(send! (irc-outbound C who (format "You said: '~a'" body))))
|
||||
|
||||
(on (asserted (irc-presence C NICK CHAN))
|
||||
(send! (irc-outbound C CHAN "Hello, everybody!")))
|
||||
|
||||
(during (irc-presence C $who CHAN)
|
||||
(on-start (log-info "~a joins ~a" who CHAN))
|
||||
(on-stop (log-info "~a leaves ~a" who CHAN)))
|
||||
|
||||
(on (message (irc-inbound C $who CHAN $body))
|
||||
(log-info "~a says: ~a" who body)
|
||||
(when (not (equal? who NICK))
|
||||
(send! (irc-outbound C CHAN (format "Hey, ~a said '~a'" who body))))))
|
Loading…
Reference in New Issue