#:use-module (8sync repl)
#:use-module (8sync agenda)
#:use-module (8sync actors)
+ #:use-module (8sync contrib irc)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 format)
#:use-module (ice-9 receive)
#:export (<irc-bot>
irc-bot-username irc-bot-server irc-bot-channels irc-bot-port
- irc-bot-send-line
+ dispatch-message handle-message
- handle-line handle-misc-input
- handle-user-join handle-user-quit
+ default-irc-port ;REMOVEME compat
+ irc-bot-send-line ;REMOVEME compat
+ handle-line handle-misc-input)) ;REMOVEME compat
- default-irc-port))
-
-\f
-;;; Network stuff
-;;; =============
-
-(define default-irc-port 6665)
-
-(define* (irc-socket-setup hostname #:optional (inet-port default-irc-port))
- (let* ((s (socket PF_INET SOCK_STREAM 0))
- (flags (fcntl s F_GETFL))
- (ip-address (inet-ntop AF_INET (car (hostent:addr-list (gethost hostname))))))
- (cond (s
- (fcntl s F_SETFL (logior O_NONBLOCK flags))
- (connect s AF_INET (inet-pton AF_INET ip-address) inet-port)
- s)
- (else
- (8sleep 1)
- (irc-socket-setup hostname inet-port)))))
-
-(define irc-eol "\r\n")
-
-(define (startswith-colon? str)
- (and (> (string-length str) 0)
- (eq? (string-ref str 0)
- #\:)))
-
-;; TODO: This needs a cleanup. Maybe even just using a regex is fine.
-(define (parse-line line)
- (define (parse-params pre-params)
- ;; This is stupid and imperative but I can't wrap my brain around
- ;; the right way to do it in a functional way :\
- (let ((param-list '())
- (currently-building '()))
- (for-each
- (lambda (param-item)
- (cond
- ((startswith-colon? param-item)
- (if (not (eq? currently-building '()))
- (set! param-list
- (cons
- (reverse currently-building)
- param-list)))
- (set! currently-building (list param-item)))
- (else
- (set! currently-building (cons param-item currently-building)))))
- pre-params)
- ;; We're still building something, so tack that on there
- (if (not (eq? currently-building '()))
- (set! param-list
- (cons (reverse currently-building) param-list)))
- ;; return the reverse of the param list
- (reverse param-list)))
-
- (match (string-split line #\space)
- (((? startswith-colon? prefix)
- command
- pre-params ...)
- (values prefix command
- (parse-params pre-params)))
- ((command pre-params ...)
- (values #f command
- (parse-params pre-params)))))
-
-(define (strip-colon-if-necessary string)
- (if (and (> (string-length string) 0)
- (string-ref string 0))
- (substring/copy string 1)
- string))
-
-;; @@: Not sure if this works in all cases, like what about in a non-privmsg one?
-(define (irc-line-username irc-line-prefix)
- (let* ((prefix-name (strip-colon-if-necessary irc-line-prefix))
- (exclaim-index (string-index prefix-name #\!)))
- (if exclaim-index
- (substring/copy prefix-name 0 exclaim-index)
- prefix-name)))
-
-(define (condense-privmsg-line line)
- "Condense message line and do multiple value return of
- (channel message emote?)"
- (define (strip-last-char string)
- (substring/copy string 0 (- (string-length string) 1)))
- (let* ((channel-name (caar line))
- (rest-params (apply append (cdr line))))
- (match rest-params
- (((or "\x01ACTION" ":\x01ACTION") middle-words ... (= strip-last-char last-word))
- (values channel-name
- (string-join
- (append middle-words (list last-word))
- " ")
- #t))
- (((= strip-colon-if-necessary first-word) rest-message ...)
- (values channel-name
- (string-join (cons first-word rest-message) " ")
- #f)))))
-
-;;; A goofy default
+;;; A goofy default handler.
(define* (echo-message irc-bot speaker channel-name
line-text emote? #:key (port (current-output-port)))
"Simply echoes the message to the PORT."
(channels #:init-keyword #:channels
#:getter irc-bot-channels)
(port #:init-keyword #:port
- #:init-value default-irc-port
+ #:init-value %irc:default-port
#:getter irc-bot-port)
(socket #:accessor irc-bot-socket)
(actions #:allocation #:each-subclass
(*init* irc-bot-init)
(*cleanup* irc-bot-cleanup)
(main-loop irc-bot-main-loop)
- (handle-line handle-line)
+ (dispatch-message dispatch-message)
+ (handle-line handle-line) ;REMOVEME compat
(send-line irc-bot-send-line-action))))
(define (irc-bot-realname irc-bot)
(define (irc-bot-init irc-bot message)
"Initialize the IRC bot"
- (define socket
- (irc-socket-setup (irc-bot-server irc-bot)
- (irc-bot-port irc-bot)))
+ (define socket (irc:listen (irc-bot-server irc-bot)
+ #:port (irc-bot-port irc-bot)
+ #:sleep 8sleep))
+ (define flags (fcntl socket F_GETFL))
+
+ (fcntl socket F_SETFL (logior O_NONBLOCK flags))
(set! (irc-bot-socket irc-bot) socket)
- (format socket "USER ~a ~a ~a :~a~a"
- (irc-bot-username irc-bot)
- "*" "*" ; hostname and servername
- (irc-bot-realname irc-bot) irc-eol)
- (format socket "NICK ~a~a" (irc-bot-username irc-bot) irc-eol)
- (for-each
- (lambda (channel)
- (format socket "JOIN ~a~a" channel irc-eol))
- (irc-bot-channels irc-bot))
+ (irc:user socket (irc-bot-username irc-bot)
+ #:real (irc-bot-realname irc-bot))
+ (irc:nick socket (irc-bot-username irc-bot))
+
+ (for-each (cute irc:join socket <>) (irc-bot-channels irc-bot))
(<- (actor-id irc-bot) 'main-loop))
(define (irc-bot-main-loop irc-bot message)
(define socket (irc-bot-socket irc-bot))
- (define line (string-trim-right (read-line socket) #\return))
- (dispatch-raw-line irc-bot line)
+ (define line (irc:receive socket))
+ (define message (or (false-if-exception (irc:line->message line))
+ line))
+ (<- (actor-id irc-bot) 'dispatch-message message)
(cond
;; The port's been closed for some reason, so stop looping
((port-closed? socket)
(define* (irc-bot-send-line-action irc-bot message
channel line #:key emote?)
"Action handler for sending lines. Real behavior happens in
-irc-bot-send-line."
- (irc-bot-send-line irc-bot channel line #:emote? emote?))
+irc:send-line."
+ (define socket (irc-bot-socket irc-bot))
+ (irc:send-line socket channel line #:emote? emote?))
+
+\f
+;;;
+;;; Likely-to-be-overridden generic methods
+;;;
+(define-method (dispatch-message (irc-bot <irc-bot>) 8sync-message message)
+ "Dispatch an <irc:message>."
+ (match message
+ ((and ($ <irc:message>)
+ (= irc:message-command 'PING)
+ (= irc:message-message message))
+ (irc:pong (irc-bot-socket irc-bot) message))
+ (_ (handle-message irc-bot message))))
+
+(define-method (handle-message (irc-bot <irc-bot>) message)
+ (match message
+ ((and ($ <irc:message>)
+ (= irc:message-line line)
+ (= irc:message-command command)
+ (= irc:message-speaker speaker)
+ (= irc:message-channel channel)
+ (= irc:message-message message)
+ (= irc:message-emote? emote?))
+ (or
+ (case command
+ ((PRIVMSG)
+ (handle-line irc-bot #f speaker channel message emote?)) ;REMOVEME compat
+ (else
+ (handle-misc-input irc-bot line))) ;REMOVEME compat
+ (echo-message irc-bot speaker channel message #f
+ #:port (current-error-port))))))
+
+\f
+;;;
+;;; Compatibility with 0.4.2.
+;;;
+(define default-irc-port %irc:default-port)
+(define irc-eol %irc:eol)
(define* (irc-bot-send-line irc-bot channel line #:key emote?)
- ;; TODO: emote? handling
- (format (irc-bot-socket irc-bot) "PRIVMSG ~a :~a~a"
- channel line irc-eol))
+ (define socket (irc-bot-socket irc-bot))
+ (irc:send-line socket channel line))
+(define-method (handle-line (irc-bot <irc-bot>) ;REMOVEME compat
+ 8sync-message
+ username channel-name line-text emote?)
+ "Keep compatibility with previous release."
+ #f)
-;;; Likely-to-be-overridden generic methods
+(define-method (handle-misc-input (irc-bot <irc-bot>) ;REMOVEME compat
+ (line <string>))
+ "Keep compatibility with previous release."
+ #f)
-(define-method (dispatch-raw-line (irc-bot <irc-bot>) raw-line)
- "Dispatch a raw line of input"
- (receive (line-prefix line-command line-params)
- (parse-line raw-line)
- (match line-command
- ("PING"
- (display (string-append "PONG" irc-eol)
- (irc-bot-socket irc-bot)))
- ("PRIVMSG"
- (receive (channel-name line-text emote?)
- (condense-privmsg-line line-params)
- (let ((username (irc-line-username line-prefix)))
- (<- (actor-id irc-bot) 'handle-line
- username channel-name
- line-text emote?))))
- (_ (handle-misc-input irc-bot raw-line)))))
+(define (startswith-colon? str)
+ (and (> (string-length str) 0)
+ (eq? (string-ref str 0)
+ #\:)))
-(define-method (handle-line (irc-bot <irc-bot>) message
- username channel-name line-text emote?)
- (echo-message irc-bot username channel-name line-text emote?
- #:port (current-error-port)))
+;; TODO: This needs a cleanup. Maybe even just using a regex is fine.
+(define (parse-line line) ;REMOVEME compat
+ (define (parse-params pre-params)
+ ;; This is stupid and imperative but I can't wrap my brain around
+ ;; the right way to do it in a functional way :\
+ (let ((param-list '())
+ (currently-building '()))
+ (for-each
+ (lambda (param-item)
+ (cond
+ ((startswith-colon? param-item)
+ (if (not (eq? currently-building '()))
+ (set! param-list
+ (cons
+ (reverse currently-building)
+ param-list)))
+ (set! currently-building (list param-item)))
+ (else
+ (set! currently-building (cons param-item currently-building)))))
+ pre-params)
+ ;; We're still building something, so tack that on there
+ (if (not (eq? currently-building '()))
+ (set! param-list
+ (cons (reverse currently-building) param-list)))
+ ;; return the reverse of the param list
+ (reverse param-list)))
-(define-method (handle-misc-input (irc-bot <irc-bot>) raw-line)
- (display raw-line)
- (newline))
+ (match (string-split line #\space)
+ (((? startswith-colon? prefix)
+ command
+ pre-params ...)
+ (values prefix command
+ (parse-params pre-params)))
+ ((command pre-params ...)
+ (values #f command
+ (parse-params pre-params)))))
-(define-method (handle-user-join (irc-bot <irc-bot>) user channel)
- 'TODO)
+(define (strip-colon-if-necessary string) ;REMOVME compat
+ (if (and (> (string-length string) 0)
+ (string-ref string 0))
+ (substring/copy string 1)
+ string))
-(define-method (handle-user-quit (irc-bot <irc-bot>) user channel)
- 'TODO)
+;; @@: Not sure if this works in all cases, like what about in a non-privmsg one?
+(define (irc-line-username irc-line-prefix) ;REMOVME compat
+ (let* ((prefix-name (strip-colon-if-necessary irc-line-prefix))
+ (exclaim-index (string-index prefix-name #\!)))
+ (if exclaim-index
+ (substring/copy prefix-name 0 exclaim-index)
+ prefix-name)))
+(define (condense-privmsg-line line) ;REMOVME compat
+ "Condense message line and do multiple value return of
+ (channel message emote?)"
+ (define (strip-last-char string)
+ (substring/copy string 0 (- (string-length string) 1)))
+ (let* ((channel-name (caar line))
+ (rest-params (apply append (cdr line))))
+ (match rest-params
+ (((or "\x01ACTION" ":\x01ACTION") middle-words ... (= strip-last-char last-word))
+ (values channel-name
+ (string-join
+ (append middle-words (list last-word))
+ " ")
+ #t))
+ (((= strip-colon-if-necessary first-word) rest-message ...)
+ (values channel-name
+ (string-join (cons first-word rest-message) " ")
+ #f)))))
projects / 8sync.git / commitdiff