--- /dev/null
+;;; Snuik --- An IRC bot using guile-8sync
+;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Snuik.
+;;;
+;;; Snuik is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Snuik is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Snuik. If not, see <http://www.gnu.org/licenses/>.
+;;;
+;;; Commentary:
+;;;
+;;; Low-level IRC procedures imported from Snuik; (snuik irc).
+;;;
+;;; Code:
+
+(define-module (8sync contrib irc)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-71)
+
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+
+ #:export (%irc:action-regexp
+ %irc:default-port
+ %irc:line-regexp
+ %irc:eol
+ %irc:prefix-regexp
+
+ <irc:message>
+ make-irc:message
+ irc:message?
+ irc:message-line
+ irc:message-command
+ irc:message-prefix
+ irc:message-params
+ irc:message-speaker
+ irc:message-channel
+ irc:message-message
+ irc:message-emote?
+ irc:message-private?
+
+ irc:action
+ irc:emote
+ irc:join
+ irc:leave
+ irc:line->message
+ irc:listen
+ irc:names
+ irc:nick
+ irc:notice
+ irc:params->channel+message+emote?
+ irc:parse
+ irc:parse-params
+ irc:part
+ irc:pong
+ irc:prefix->host+user+nick
+ irc:prefix->nick
+ irc:quit
+ irc:receive
+ irc:send
+ irc:send-line
+ irc:send-message
+ irc:user))
+
+;;;
+;;; Constants.
+;;;
+(define %irc:default-port 6665)
+
+(define %irc:eol "\r\n")
+
+(define %irc:action-regexp "\x01(ACTION) ([^\x01]+)\x01")
+(define %irc:line-regexp "(:[^ ]+ )?([A-Za-z0-9]+)(.*)")
+(define %irc:prefix-regexp "^([^!]+)!~?([^@]+)@(.+)")
+(define %irc:quote-regexp "(.*)[: ]*\x02([^\x02]+)\x02(.*)")
+
+\f
+;;;
+;;; Utilities, from (snuik util).
+;;;
+(define (match:positions m)
+ "If string-match M succeeded, return the positions of its substring
+matches as a list."
+ (and m
+ (match (vector->list m)
+ ((string positions ...)
+ positions))))
+
+(define (match:substrings m)
+ "If string-match M succeeded, return its substrings as a list."
+ (and m
+ (let ((lst (vector->list m)))
+ (map (cute match:substring m <>) (iota (1- (length lst)))))))
+
+\f
+;;;
+;;; Listen.
+;;;
+(define* (irc:listen hostname #:key (port %irc:default-port) (sleep sleep))
+ (let ((socket (socket PF_INET SOCK_STREAM 0)))
+ (cond
+ (socket
+ (let* ((flags (fcntl socket F_GETFL))
+ (network-addresses (hostent:addr-list (gethost hostname))))
+ (match network-addresses
+ ((address rest ...)
+ (let ((ip-address (inet-ntop AF_INET address)))
+ (connect socket AF_INET (inet-pton AF_INET ip-address) port))))
+ socket))
+ (else
+ (sleep 1)
+ (irc:listen hostname #:port port #:sleep sleep)))))
+
+(define (irc:receive socket)
+ (string-trim-right (read-line socket) #\return))
+
+(define (irc:send socket template . args)
+ (let ((line (apply format #f template args)))
+ (format socket "~a~a" line %irc:eol)))
+
+\f
+;;;
+;;; Commands.
+;;;
+(define (irc:action socket channel line)
+ (let ((line (format #f "\\x01ACTION ~a\\x01" line)))
+ (irc:send socket channel line)))
+
+(define irc:emote irc:action)
+
+(define (irc:join socket channel)
+ (irc:send socket "JOIN ~a" channel))
+
+(define (irc:names socket channel)
+ (irc:send socket "NAMES ~a" channel))
+
+(define (irc:nick socket nick)
+ (irc:send socket "NICK ~a" nick))
+
+(define (irc:notice socket channel line)
+ (irc:send socket "NOTICE ~a :~a" channel line))
+
+(define (irc:part socket channel)
+ (irc:send socket "PART ~a" channel))
+
+(define irc:leave irc:part)
+
+(define* (irc:pong socket #:optional pong)
+ (irc:send socket "PONG ~a" pong))
+
+(define (irc:privmsg socket channel line)
+ (irc:send socket "PRIVMSG ~a :~a" channel line))
+
+(define* (irc:quit socket #:optional message)
+ (let ((message (if message (format #f " :~a" message)
+ "")))
+ (irc:send socket "QUIT~a" message)
+ (close socket)))
+
+(define* (irc:user socket user #:key (host "*") (real user) (server "*"))
+ (irc:send socket "USER ~a ~a ~a :~a" user host server real))
+
+\f
+;;;
+;;; Send message.
+;;;
+(define* (irc:send-line socket channel line #:key emote?)
+ (let ((send (if emote? irc:emote
+ irc:privmsg)))
+ (irc:privmsg socket channel line)))
+
+(define* (irc:send-message socket channel message #:key emote?)
+ (let ((lines (string-split message #\newline)))
+ (for-each (cut irc:send-line socket channel <> #:emote? emote?) lines)))
+
+\f
+;;;
+;;; Parse message.
+;;;
+(define-immutable-record-type <irc:message>
+ (make-irc:message line command prefix params
+ speaker channel message emote? private?)
+ irc:message?
+ (line irc:message-line)
+ (command irc:message-command)
+ (prefix irc:message-prefix)
+ (params irc:message-params)
+ (channel irc:message-channel)
+ (speaker irc:message-speaker)
+ (message irc:message-message)
+ (emote? irc:message-emote?)
+ (private? irc:message-private?))
+
+(define (irc:parse-params params)
+ (let* ((params (string-trim-both params))
+ (m (string-match ":(.+)" params)))
+ (match (match:positions m)
+ (((start . _) . _)
+ (let* ((message (substring params (1+ start) (string-length params)))
+ (m (string-match %irc:action-regexp message))
+ (param (match (match:substrings m)
+ ((_ action message) `(,(string->symbol action) ,message))
+ (_ message))))
+ (append (irc:parse-params (substring params 0 start)) (list param))))
+ (_ (string-split params #\space)))))
+
+(define (irc:prefix->host+user+nick prefix)
+ "Parse PREFIX and return three values, NICK, USER, and HOST."
+ (match prefix
+ ((? string?)
+ (let ((m (string-match %irc:prefix-regexp prefix)))
+ (if (not m) (values prefix #f #f)
+ (match (match:substrings m)
+ ((_ nick host user)
+ (values host user nick))))))
+ (_ (values prefix #f #f))))
+
+(define (irc:prefix->nick prefix)
+ "Parse PREFIX and return NICK."
+ (let ((host user nick (irc:prefix->host+user+nick prefix)))
+ nick))
+
+(define (irc:parse line)
+ "Parse LINE and return four values: LINE, COMMAND, PREFIX, and PARAMS."
+ (let ((m (string-match %irc:line-regexp line)))
+ (match (match:substrings m)
+ ((_ prefix command params)
+ (let* ((code (and=> command string->number))
+ (command (or code (and=> command string->symbol)))
+ (prefix (and=> prefix (cute substring <> 1)))
+ (params (irc:parse-params params)))
+ (values line command prefix params)))
+ ((prefix command)
+ (let ((nick (irc:prefix->nick prefix)))
+ (values line command prefix '())))
+ (_ (values line #f #f '())))))
+
+(define (irc:params->channel+message+emote? params)
+ "Parse PARAMS and return three values, CHANNEL, MESSAGE, and EMOTE?"
+ (match params
+ ((channel (and (? string?) words) ...)
+ (let ((message (string-join words)))
+ (values channel message #f)))
+ ((channel ('ACTION (and words (? string?))) ...)
+ (let ((message (string-join words)))
+ (values channel message #t)))
+ (_ (values #f #f #f))))
+
+(define (irc:line->message line)
+ "Parse LINE and return an <irc:message>."
+ (call-with-values (cute irc:parse line)
+ (lambda (line command prefix params)
+ (let* ((host user nick (irc:prefix->host+user+nick prefix))
+ (channel message emote?
+ (irc:params->channel+message+emote? params))
+ (private? (and (string? channel)
+ (not (string-prefix? "#" channel)))))
+ (make-irc:message line command prefix params
+ nick channel message emote? private?)))))
projects / 8sync.git / commitdiff