syndicate-2017/racket/syndicate/drivers/irc.rkt

116 lines
4.6 KiB
Racket

#lang syndicate
;; 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
(spawn #:name 'irc-connection-factory
(during (observe (irc-inbound $C _ _ _))
(assert C))
(during (observe (observe (irc-outbound $C _ _)))
(assert C))
(during/spawn (irc-connection $host $port $nick)
#:spawn supervise/spawn
#: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])))
(names-acc (set-union (names-acc) new-names))]
[(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))]
[(regexp #px#"^:([^!]+)![^ ]* PART ([^ ]+)\r$" (list _ src tgt))
(retract! (irc-presence C (bytes->string/utf-8 src) (bytes->string/utf-8 tgt)))
(when (equal? (bytes->string/utf-8 src) nick)
(retract! (irc-presence C ? (bytes->string/utf-8 tgt))))]
[(regexp #px#"^:([^!]+)![^ ]* QUIT :(.*)\r$" (list _ src _quitmsg))
(retract! (irc-presence C (bytes->string/utf-8 src) ?))]
[(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)]))))