Crude IRC driver and example.

This commit is contained in:
Tony Garnock-Jones 2017-01-07 01:14:14 -05:00
parent 7cc62688f9
commit eb4a228c73
2 changed files with 134 additions and 0 deletions

View File

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

View File

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