2017-01-07 06:14:14 +00:00
|
|
|
#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
|
|
|
|
|
2017-02-15 23:18:19 +00:00
|
|
|
(spawn #:name 'irc-connection-factory
|
2017-01-07 06:14:14 +00:00
|
|
|
|
|
|
|
(during (observe (irc-inbound $C _ _ _))
|
|
|
|
(assert C))
|
|
|
|
|
|
|
|
(during (observe (observe (irc-outbound $C _ _)))
|
|
|
|
(assert C))
|
|
|
|
|
2017-02-15 23:18:19 +00:00
|
|
|
(during/spawn (irc-connection $host $port $nick)
|
2017-02-20 18:29:19 +00:00
|
|
|
#:spawn supervise/spawn
|
2017-01-07 06:14:14 +00:00
|
|
|
#: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
|
2017-01-08 19:10:15 +00:00
|
|
|
|
2017-01-07 06:14:14 +00:00
|
|
|
[(regexp #px#"^PING(.*)\r$" (list _ line-tail))
|
|
|
|
(irc-send! "PONG"line-tail)]
|
2017-01-08 19:10:15 +00:00
|
|
|
|
2017-01-07 06:14:14 +00:00
|
|
|
[(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)))]
|
2017-01-08 19:10:15 +00:00
|
|
|
|
2017-01-07 06:14:14 +00:00
|
|
|
[(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])))
|
|
|
|
(names-acc (set-union (names-acc) new-names))]
|
2017-01-08 19:10:15 +00:00
|
|
|
|
2017-01-07 06:14:14 +00:00
|
|
|
[(regexp #px#"^:[^ ]* 366 " (list _))
|
|
|
|
(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))]
|
2017-01-08 19:10:15 +00:00
|
|
|
|
2017-01-07 06:14:14 +00:00
|
|
|
[(regexp #px#"^:([^!]+)![^ ]* PART ([^ ]+)\r$" (list _ src tgt))
|
2017-01-08 19:10:15 +00:00
|
|
|
(retract! (irc-presence C (bytes->string/utf-8 src) (bytes->string/utf-8 tgt)))]
|
|
|
|
|
2017-01-07 06:46:09 +00:00
|
|
|
[(regexp #px#"^:([^!]+)![^ ]* QUIT :(.*)\r$" (list _ src _quitmsg))
|
|
|
|
(retract! (irc-presence C (bytes->string/utf-8 src) ?))]
|
2017-01-08 19:10:15 +00:00
|
|
|
|
2017-01-07 06:14:14 +00:00
|
|
|
[(regexp #px#"^:([^!]+)![^ ]* JOIN ([^ ]+)\r$" (list _ src-bs tgt))
|
|
|
|
(define src (bytes->string/utf-8 src-bs))
|
|
|
|
(when (not (equal? src nick)) ;; See above marked (*)
|
2017-01-08 19:10:15 +00:00
|
|
|
(assert! (irc-presence C src (bytes->string/utf-8 tgt))))]
|
|
|
|
|
2017-01-07 06:14:14 +00:00
|
|
|
[_ (void)]))))
|